Session Quasi_Borel_Spaces

ody>

Theory StandardBorel

(*  Title:   StandardBorel.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

section  ‹Standard Borel Spaces›
theory StandardBorel
  imports "HOL-Probability.Probability"
begin

text ‹A standard Borel space is the Borel space associated with a Polish space.
      Here, we define standard Borel spaces in another, but equivallent, way.
      See @{cite "Heunen_2017"} Proposition 5. ›
abbreviation "real_borel ≡ borel :: real measure"
abbreviation "nat_borel ≡ borel :: nat measure"
abbreviation "ennreal_borel ≡ borel :: ennreal measure"
abbreviation "bool_borel ≡ borel :: bool measure"


subsection ‹ Definition ›
locale standard_borel =
  fixes M :: "'a measure"
  assumes exist_fg: "∃f ∈ M →M real_borel. ∃g ∈ real_borel →M M.
                     ∀x ∈ space M.  (g ∘ f) x = x"
begin

abbreviation "fg ≡ (SOME k. (fst k) ∈ M →M real_borel ∧ 
                           (snd k) ∈ real_borel →M M ∧
                           (∀x ∈ space M.  ((snd k) ∘ (fst k)) x = x))"

definition "f ≡ (fst fg)"
definition "g ≡ (snd fg)"

lemma 
  shows f_meas[simp,measurable]    :  "f ∈ M →M real_borel"
    and g_meas[simp,measurable]    :  "g ∈ real_borel →M M"
    and gf_comp_id[simp]:  "⋀x. x ∈ space M ⟹ (g ∘ f) x = x"
                           "⋀x. x ∈ space M ⟹ g (f x) = x"
proof -
  obtain f' g' where h:
    "f' ∈ M →M real_borel" "g' ∈ real_borel →M M" "∀x ∈ space M.  (g' ∘ f') x = x"
    using exist_fg by blast
  have "f ∈ borel_measurable M ∧ g ∈ real_borel →M M ∧ (∀x∈space M. (g ∘ f) x = x)"
    unfolding f_def g_def
    by(rule someI2[where a="(f',g')"]) (use h in auto)
  thus "f ∈ borel_measurable M" "g ∈ real_borel →M M"
       "⋀x. x ∈ space M ⟹ (g ∘ f) x = x" "⋀x. x ∈ space M ⟹ g (f x) = x"
    by auto
qed

lemma standard_borel_sets[simp]:
  assumes "sets M = sets Y"
  shows "standard_borel Y"
  unfolding standard_borel_def
  using measurable_cong_sets[OF assms refl,of real_borel] measurable_cong_sets[OF refl assms,of real_borel] sets_eq_imp_space_eq[OF assms] exist_fg
  by simp

lemma f_inj:
  "inj_on f (space M)"
  by standard (use gf_comp_id(2) in fastforce)

lemma singleton_sets:
  assumes "x ∈ space M"
    shows "{x} ∈ sets M"
proof -
  let ?y = "f x"
  let ?U = "f -` {?y}"
  have "?U ∩ space M ∈ sets M"
    using borel_measurable_vimage f_meas by blast
  moreover have "?U ∩ space M = {x}"
    using assms f_inj by(auto simp:inj_on_def)
  ultimately show ?thesis
    by simp
qed

lemma countable_space_discrete:
  assumes "countable (space M)"
  shows "sets M = sets (count_space (space M))"
proof
  show "sets (count_space (space M)) ⊆ sets M"
  proof auto
    fix U
    assume 1:"U ⊆ space M"
    then have 2:"countable U"
      using assms countable_subset by auto
    have 3:"U = (⋃x∈U. {x})" by auto
    moreover have "... ∈ sets M"
      by(rule sets.countable_UN''[of U "λx. {x}"]) (use 1 2 singleton_sets in auto)
    ultimately show "U ∈ sets M"
      by simp
  qed
qed (simp add: sets.sets_into_space subsetI)

end

lemma standard_borelI:
  assumes "f ∈ Y →M real_borel"
          "g ∈ real_borel →M Y"
      and "⋀y. y ∈ space Y ⟹  (g ∘ f) y = y"
    shows "standard_borel Y"
  unfolding standard_borel_def
  by (intro bexI[OF _ assms(1)] bexI[OF _ assms(2)]) (auto dest: assms(3))


locale standard_borel_space_UNIV = standard_borel +
  assumes space_UNIV:"space M = UNIV"
begin

lemma gf_comp_id'[simp]:
  "g ∘ f = id" "g (f x) = x"
  using space_UNIV gf_comp_id
  by(simp_all add: id_def comp_def)

lemma f_inj':
  "inj f"
  using f_inj by(simp add: space_UNIV)

lemma g_surj':
  "surj g"
  using gf_comp_id'(2) surjI by blast

end

lemma standard_borel_space_UNIVI:
  assumes "f ∈ Y →M real_borel"
          "g ∈ real_borel →M Y"
          "(g ∘ f) = id"
      and "space Y = UNIV"
    shows "standard_borel_space_UNIV Y"
  using assms
  by(auto intro!: standard_borelI simp: standard_borel_space_UNIV_def standard_borel_space_UNIV_axioms_def)

lemma standard_borel_space_UNIVI':
  assumes "standard_borel Y"
      and "space Y = UNIV"
    shows "standard_borel_space_UNIV Y"
  using assms by(simp add: standard_borel_space_UNIV_def standard_borel_space_UNIV_axioms_def)

subsection ‹ $\mathbb{R}$, $\mathbb{N}$, Boolean, $[0,\infty]$ ›
text ‹ $\mathbb{R}$ is a standard Borel space. ›
interpretation real : standard_borel_space_UNIV "real_borel"
  by(auto intro!: standard_borel_space_UNIVI)  

text‹ A non-empty Borel subspace of $\mathbb{R}$ is also a standard Borel space. ›
lemma real_standard_borel_subset:
  assumes "U ∈ sets real_borel"
      and "U ≠ {}"
    shows "standard_borel (restrict_space real_borel U)"
proof -
  have std1: "id ∈ (restrict_space real_borel U) →M real_borel"
    by (simp add: measurable_restrict_space1)
  obtain x where hx : "x ∈ U"
    using assms(2) by auto
  define g :: "real ⇒ real"
    where "g ≡ (λr. if r ∈ U then r else x)"
  have "g ∈ real_borel →M real_borel"
    unfolding g_def by(rule borel_measurable_continuous_on_if) (simp_all add: assms(1))
  hence std2: "g ∈ real_borel →M (restrict_space real_borel U)"
    by(auto intro!: measurable_restrict_space2 simp: g_def hx)
  have std3: "∀y∈ space (restrict_space real_borel U). (g ∘ id) y = y"
    by(simp add: g_def space_restrict_space)
  show ?thesis
    using std1 std2 std3 standard_borel_def by blast
qed

text ‹ A non-empty measurable subset of a standard Borel space is also a standard Borel space.›
lemma(in standard_borel) standard_borel_subset:
  assumes "U ∈ sets M"
          "U ≠ {}"
    shows "standard_borel (restrict_space M U)"
proof -
  let ?ginvU = "g -` U"
  have hgu1:"?ginvU ∈ sets real_borel"
    using assms(1) g_meas measurable_sets_borel by blast
  have hgu2:"f ` U ⊆ ?ginvU"
    using gf_comp_id sets.sets_into_space[OF assms(1)] by fastforce
  hence hgu3:"?ginvU ≠ {}"
    using assms(2) by blast
  interpret r_borel_set: standard_borel "restrict_space real_borel ?ginvU"
    by(rule real_standard_borel_subset[OF hgu1 hgu3])
 
  have std1: "r_borel_set.f ∘ f ∈ (restrict_space M U) →M real_borel"
    using sets.sets_into_space[OF assms(1)]
    by(auto intro!: measurable_comp[where N="restrict_space real_borel ?ginvU"] measurable_restrict_space3)
  have std2: "g ∘ r_borel_set.g ∈ real_borel →M (restrict_space M U)"
    by(auto intro!: measurable_comp[where N="restrict_space real_borel ?ginvU"] measurable_restrict_space3[OF g_meas])
  have std3: "∀x∈ space (restrict_space M U). ((g ∘ r_borel_set.g) ∘ (r_borel_set.f ∘ f)) x = x"
    by (simp add: space_restrict_space)
  show ?thesis
    using std1 std2 std3 standard_borel_def by blast
qed

text ‹ $\mathbb{N}$ is a standard Borel space. ›
interpretation nat : standard_borel_space_UNIV nat_borel
proof -
  define n_to_r :: "nat ⇒ real"
    where "n_to_r ≡ (λn. of_real n)"
  define r_to_n :: "real ⇒ nat"
    where "r_to_n ≡ (λr. nat ⌊r⌋)"

  have n_to_r_measurable: "n_to_r ∈ nat_borel →M real_borel"
    using borel_measurable_count_space measurable_cong_sets sets_borel_eq_count_space
    by blast
  have r_to_n_measurable: "r_to_n ∈ real_borel →M nat_borel"
    by(simp add: r_to_n_def)
  have n_to_r_to_n_id: "r_to_n ∘ n_to_r = id"
    by(simp add: n_to_r_def r_to_n_def comp_def id_def)
  show "standard_borel_space_UNIV nat_borel"
    using standard_borel_space_UNIVI[OF n_to_r_measurable r_to_n_measurable n_to_r_to_n_id]
    by simp
qed

text ‹ For a countable space $X$, $X$ is a standard Borel space iff $X$ is a discrete space. ›
lemma countable_standard_iff:
  assumes "space X ≠ {}"
      and "countable (space X)"
  shows "standard_borel X ⟷ sets X = sets (count_space (space X))"
proof
  show "standard_borel X ⟹ sets X = sets (count_space (space X))"
    using standard_borel.countable_space_discrete assms by simp
next
  assume h[measurable_cong]: "sets X = sets (count_space (space X))"
  show "standard_borel X"
  proof(rule standard_borelI[where f="nat.f ∘ to_nat_on (space X)" and g="from_nat_into (space X) ∘ nat.g"])
    show "nat.f ∘ to_nat_on (space X) ∈ borel_measurable X"
      by simp
  next
    have [simp]: "from_nat_into (space X) ∈ UNIV → (space X)"
      using from_nat_into[OF assms(1)] by simp
    hence [measurable]: "from_nat_into (space X) ∈ nat_borel →M X"
      using measurable_count_space_eq1[of _ _ X] measurable_cong_sets[OF sets_borel_eq_count_space]
      by blast
    show "from_nat_into (space X) ∘ nat.g ∈ real_borel →M X"
      by simp
  next
    fix x
    assume "x ∈ space X"
    then show "(from_nat_into (space X) ∘ nat.g ∘ (nat.f ∘ to_nat_on (space X))) x = x"
      using from_nat_into_to_nat_on[OF assms(2)] by simp
  qed
qed

text ‹ $\mathbb{B}$ is a standard Borel space. ›
lemma to_bool_measurable:
  assumes "f -` {True} ∩ space M  ∈ sets M"
  shows "f ∈ M →M bool_borel"
proof(rule measurableI)
  fix A
  assume h:"A ∈ sets bool_borel"
  have h2: "f -` {False} ∩ space M  ∈ sets M"
  proof -
    have "- {False} = {True}"
      by auto
    thus ?thesis
      by(simp add: vimage_sets_compl_iff[where A="{False}"] assms)
  qed
  have "A ⊆ {True,False}"
    by auto
  then consider "A = {}" | "A = {True}" | "A = {False}" | "A = {True,False}"
    by auto
  thus "f -` A ∩ space M ∈ sets M"
  proof cases
    case 1
    then show ?thesis
      by simp
  next
    case 2
    then show ?thesis
      by(simp add: assms)
  next
    case 3
    then show ?thesis
      by(simp add: h2)
  next
    case 4
    then have "f -` A = f -` {True} ∪ f -` {False}"
      by auto
    thus ?thesis
      using assms h2
      by (metis Int_Un_distrib2 sets.Un)
  qed
qed simp

interpretation bool : standard_borel_space_UNIV bool_borel
  using countable_standard_iff[of bool_borel]
  by(auto intro!: standard_borel_space_UNIVI' simp: sets_borel_eq_count_space)


text ‹ $[0,\infty]$ (the set of extended non-negative real numbers) is a standard Borel space.  ›
interpretation ennreal : standard_borel_space_UNIV ennreal_borel
proof -
  define preal_to_real :: "ennreal ⇒ real"
    where "preal_to_real ≡ (λr. if r = ∞ then -1
                                           else enn2real r)"
  define real_to_preal :: "real ⇒ ennreal"
    where "real_to_preal ≡ (λr. if r = -1 then ∞
                                          else ennreal r)"
  have preal_to_real_measurable: "preal_to_real ∈ ennreal_borel →M real_borel"
    unfolding preal_to_real_def by simp
  have real_to_preal_measurable: "real_to_preal ∈ real_borel →M ennreal_borel"
    unfolding real_to_preal_def by simp
  have preal_real_preal_id: "real_to_preal ∘ preal_to_real = id"
  proof
    fix r :: ennreal
    show "(real_to_preal ∘ preal_to_real) r = id r"
      using ennreal_enn2real_if[of r] ennreal_neg
      by(auto simp add: real_to_preal_def preal_to_real_def)
  qed
  show "standard_borel_space_UNIV ennreal_borel"
    using standard_borel_space_UNIVI[OF preal_to_real_measurable real_to_preal_measurable preal_real_preal_id]
    by simp
qed

subsection ‹ $\mathbb{R}\times\mathbb{R}$ ›
definition real_to_01open :: "real ⇒ real" where
"real_to_01open r ≡ arctan r / pi + 1 / 2"

definition real_to_01open_inverse :: "real ⇒ real" where
"real_to_01open_inverse r ≡ tan (pi * r - (pi / 2))"

lemma real_to_01open_inverse_correct:
 "real_to_01open_inverse ∘ real_to_01open = id"
  by(auto simp add: real_to_01open_def real_to_01open_inverse_def distrib_left tan_arctan)

lemma real_to_01open_inverse_correct':
  assumes "0 < r" "r < 1"
  shows "real_to_01open (real_to_01open_inverse r) = r"
  unfolding real_to_01open_def real_to_01open_inverse_def
proof -
  have "arctan (tan (pi * r - pi / 2)) = pi * r - pi / 2"
    using  arctan_unique[of "pi * r - pi / 2"] assms
    by simp
  hence "arctan (tan (pi * r - pi / 2)) / pi + 1 / 2 = ((pi * r) - pi / 2)/ pi + 1/2"
    by simp
  also have "... = r - 1/2 + 1/2"
    by (metis (no_types, opaque_lifting) divide_inverse mult.left_neutral nonzero_mult_div_cancel_left pi_neq_zero right_diff_distrib)
  finally show "arctan (tan (pi * r - pi / 2)) / pi + 1 / 2 = r"
    by simp
qed

lemma real_to_01open_01 :
 "0 < real_to_01open r ∧ real_to_01open r < 1"
proof
  have "- pi / 2 < arctan r" by(simp add: arctan_lbound)
  hence "0 < arctan r + pi / 2" by simp
  hence "0 < (1 / pi) * (arctan r + pi / 2)" by simp
  thus "0 < real_to_01open r"
    by (simp add: add_divide_distrib real_to_01open_def)
next
  have "arctan r < pi / 2" using arctan_ubound by simp
  hence "arctan r + pi / 2 < pi" by simp
  hence "(1 / pi) * (arctan r + pi / 2) < 1" by simp
  thus "real_to_01open r < 1"
    by(simp add: real_to_01open_def add_divide_distrib)
qed

lemma real_to_01open_continuous:
 "continuous_on UNIV real_to_01open"
proof -
  have "continuous_on UNIV ((λx. x / pi + 1 / 2) ∘ arctan)"
  proof (rule continuous_on_compose)
    show "continuous_on UNIV arctan"
      by (simp add: continuous_on_arctan)
  next
    show "continuous_on (range arctan) (λx. x / pi + 1 / 2)"
      by(auto intro!: continuous_on_add continuous_on_divide)
  qed
  thus ?thesis
    by(simp add: real_to_01open_def)
qed

lemma real_to_01open_inverse_continuous:
 "continuous_on {0<..<1} real_to_01open_inverse"
  unfolding real_to_01open_inverse_def
proof(rule Transcendental.continuous_on_tan)
  have [simp]: "(λx. pi * x - pi / 2) = (λx. x - pi/2) ∘ (λx. pi * x)"
    by auto
  have "continuous_on {0<..<1} ..."
  proof(rule continuous_on_compose)
    show "continuous_on {0<..<1} ((*) pi)"
      by simp
  next
    show "continuous_on ((*) pi ` {0<..<1}) (λx. x - pi / 2)"
      using continuous_on_diff[of "(*) pi ` {0<..<1}" "λx. x"]
      by simp
  qed
  thus "continuous_on {0<..<1} (λx. pi * x - pi / 2)" by simp
next
  have "∀r∈{0<..<1::real}. -(pi/2) < pi * r - pi / 2 ∧ pi * r - pi / 2 < pi/2"
    by simp
  thus "∀r∈{0<..<1::real}. cos (pi * r - pi / 2) ≠ 0"
    using cos_gt_zero_pi by fastforce
qed

lemma real_to_01open_inverse_measurable:
 "real_to_01open_inverse ∈ restrict_space real_borel {0<..<1} →M real_borel"
  using borel_measurable_continuous_on_restrict real_to_01open_inverse_continuous
  by simp

fun r01_binary_expansion'' :: "real ⇒ nat ⇒ nat × real × real" where
"r01_binary_expansion'' r 0 = (if 1/2 ≤ r then (1,1  ,1/2)
                                            else (0,1/2,  0))" |
"r01_binary_expansion'' r (Suc n) = (let (_,ur,lr) = r01_binary_expansion'' r n;
                                           k = (ur + lr)/2 in
                                           (if k ≤ r then (1,ur,k)
                                                     else (0,k,lr)))"


text ‹ $a_n$  where $r = 0.a_0 a_1 a_2 ....$ for $0 < r < 1$.›
definition r01_binary_expansion' :: "real ⇒ nat ⇒ nat" where
"r01_binary_expansion' r n ≡ fst (r01_binary_expansion'' r n)"

text ‹$a_n = 0$ or $1$.›
lemma real01_binary_expansion'_0or1:
  "r01_binary_expansion' r n ∈ {0,1}"
  by (cases n) (simp_all add: r01_binary_expansion'_def split_beta' Let_def)

(* S_n = a_0 + ... + a_n *)
definition r01_binary_sum :: "(nat ⇒ nat) ⇒ nat ⇒ real" where
"r01_binary_sum a n ≡ (∑i=0..n. real (a i) * ((1/2)^(Suc i)))"

definition r01_binary_sum_lim :: "(nat ⇒ nat) ⇒ real" where
"r01_binary_sum_lim  ≡ lim ∘ r01_binary_sum" 


definition r01_binary_expression :: "real ⇒ nat ⇒ real" where
"r01_binary_expression ≡ r01_binary_sum ∘ r01_binary_expansion'"

lemma r01_binary_expansion_lr_r_ur:
  assumes "0 < r" "r < 1"
  shows "(snd (snd (r01_binary_expansion'' r n))) ≤ r ∧
         r < (fst (snd (r01_binary_expansion'' r n)))"
  using assms by (induction n) (simp_all add:split_beta' Let_def)

text ‹‹0 ≤ lr ∧ lr < ur ∧ ur ≤ 1›.›
lemma r01_binary_expansion_lr_ur_nn:
  shows "0 ≤ snd (snd (r01_binary_expansion'' r n)) ∧
         snd (snd (r01_binary_expansion'' r n)) < fst (snd (r01_binary_expansion'' r n)) ∧
         fst (snd (r01_binary_expansion'' r n)) ≤ 1"
  by (induction n) (simp_all add:split_beta' Let_def)

lemma r01_binary_expansion_diff:
  shows "(fst (snd (r01_binary_expansion'' r n))) - (snd (snd (r01_binary_expansion'' r n))) = (1/2)^(Suc n)"
proof(induction n)
  case (Suc n')
  then show ?case
  proof(cases "r01_binary_expansion'' r n'")
    case 1:(fields a ur lr)
    assume "fst (snd (r01_binary_expansion'' r n')) - snd (snd (r01_binary_expansion'' r n')) = (1 / 2) ^ (Suc n')"
    then have 2:"ur - lr = (1/2)^(Suc n')" by (simp add: 1)
    show ?thesis
    proof -
      have [simp]:"ur * 4 - (ur * 4 + lr * 4) / 2 = (ur - lr) * 2"
        by(simp add: division_ring_class.add_divide_distrib)
      have "ur * 4 - (ur * 4 + lr * 4) / 2 = (1 / 2) ^ n'"
        by(simp add: 2)
      moreover have "(ur * 4 + lr * 4) / 2 - lr * 4 = (1 / 2) ^ n'"
        by(simp add: division_ring_class.add_divide_distrib ring_class.right_diff_distrib[symmetric] 2)
      ultimately show ?thesis
        by(simp add: 1 Let_def)
    qed
  qed
qed simp

text ‹‹lrn = Sn›.›
lemma r01_binary_expression_eq_lr:
  "snd (snd (r01_binary_expansion'' r n)) = r01_binary_expression r n"
proof(induction n)
  case 0
  then show ?case
    by(simp add: r01_binary_expression_def r01_binary_sum_def r01_binary_expansion'_def)
next
  case 1:(Suc n')
  show ?case
  proof (cases "r01_binary_expansion'' r n'")
    case 2:(fields a ur lr)
    then have ih:"lr = (∑i = 0..n'. real (fst (r01_binary_expansion'' r i)) * (1 / 2) ^ i / 2)"
      using 1 by(simp add: r01_binary_expression_def r01_binary_sum_def r01_binary_expansion'_def)
    have 3:"(ur + lr) / 2 = lr + (1/2)^(Suc (Suc n'))"
      using r01_binary_expansion_diff[of r n'] 2 by simp
    show ?thesis
      by(simp add: r01_binary_expression_def r01_binary_sum_def r01_binary_expansion'_def 2 Let_def 3) fact
  qed
qed

lemma r01_binary_expression'_sum_range:
 "∃k::nat.  (snd (snd (r01_binary_expansion'' r n))) = real k/2^(Suc n) ∧
             k < 2^(Suc n) ∧
            ((r01_binary_expansion' r n) = 0 ⟶ even k) ∧
            ((r01_binary_expansion' r n) = 1 ⟶ odd k)"
proof -
  have [simp]:"(snd (snd (r01_binary_expansion'' r n))) = (∑i=0..n. real (r01_binary_expansion' r i) * ((1/2)^(Suc i)))"
    using r01_binary_expression_eq_lr[of r n] by(simp add: r01_binary_expression_def r01_binary_sum_def)
  have "∃k::nat. (∑i=0..n. real (r01_binary_expansion' r i) * ((1/2)^(Suc i))) = real k/2^(Suc n) ∧
             k < 2^(Suc n) ∧
            ((r01_binary_expansion' r n) = 0 ⟶ even k) ∧
            ((r01_binary_expansion' r n) = 1 ⟶ odd k)"
  proof(induction n)
    case 0
    consider "r01_binary_expansion' r 0 = 0" | "r01_binary_expansion' r 0 = 1"
      using real01_binary_expansion'_0or1[of r 0] by auto
    then show ?case
      by cases auto
  next
    case (Suc n')
    then obtain k :: nat where ih:
     "(∑i = 0..n'. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i) = real k / 2^(Suc n') ∧ k < 2^(Suc n')"
      by auto
    have "(∑i = 0..Suc n'. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i) = (∑i = 0..n'. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i) + real (r01_binary_expansion' r (Suc n')) * (1 / 2) ^ Suc (Suc n')"
      by simp
    also have "... = real k / 2^(Suc n') + (real (r01_binary_expansion' r (Suc n')))/ 2^ Suc (Suc n')"
    proof -
      have "⋀r ra n. (r::real) * (1 / ra) ^ n = r / ra ^ n"
        by (simp add: power_one_over)
      then show ?thesis
        using ih by presburger
    qed
    also have "... = (2*real k) / 2^(Suc (Suc n')) + (real (r01_binary_expansion' r (Suc n')))/ 2^ Suc (Suc n')"
      by simp
    also have "... = (2*(real k) + real (r01_binary_expansion' r (Suc n')))/2 ^ Suc (Suc n')"
      by (simp add: add_divide_distrib)
    also have "... = (real (2*k + r01_binary_expansion' r (Suc n')))/2 ^ Suc (Suc n')"
      by simp
    finally have "(∑i = 0..Suc n'. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i) = real (2 * k + r01_binary_expansion' r (Suc n')) / 2 ^ Suc (Suc n')" .
    moreover have "2 * k + r01_binary_expansion' r (Suc n') < 2^Suc (Suc n')"
    proof -
      have "k + 1 ≤ 2^Suc n'"
        using ih by simp
      hence "2*k + 2 ≤ 2^Suc (Suc n')"
        by simp
      thus ?thesis
        using real01_binary_expansion'_0or1[of r "Suc n'"]
        by auto
    qed
    moreover have "r01_binary_expansion' r (Suc n') = 0 ⟶ even (2 * k + r01_binary_expansion' r (Suc n'))"
      by simp
    moreover have "r01_binary_expansion' r (Suc n') = 1 ⟶ odd (2 * k + r01_binary_expansion' r (Suc n'))"
      by simp
    ultimately show ?case by fastforce
  qed
  thus ?thesis
    by simp
qed

text ‹‹an = bn ↔ Sn = S'n›.›
lemma r01_binary_expansion'_expression_eq:
  "r01_binary_expansion' r1 = r01_binary_expansion' r2 ⟷
   r01_binary_expression r1 = r01_binary_expression r2"
proof
  assume "r01_binary_expansion' r1 = r01_binary_expansion' r2"
  then show "r01_binary_expression r1 = r01_binary_expression r2"
    by(simp add: r01_binary_expression_def)
next
  assume "r01_binary_expression r1 = r01_binary_expression r2"
  then have 1:"⋀n. r01_binary_sum (r01_binary_expansion' r1) n = r01_binary_sum (r01_binary_expansion' r2) n"
    by(simp add: r01_binary_expression_def)
  show "r01_binary_expansion' r1 = r01_binary_expansion' r2"
  proof
    fix n
    show " r01_binary_expansion' r1 n = r01_binary_expansion' r2 n"
    proof(cases n)
      case 0
      then show ?thesis
        using 1[of 0] by(simp add: r01_binary_sum_def)
    next
      fix n'
      case (Suc n')
      have "r01_binary_sum (r01_binary_expansion' r1) n - r01_binary_sum (r01_binary_expansion' r1) n' = r01_binary_sum (r01_binary_expansion' r2) n - r01_binary_sum (r01_binary_expansion' r2) n'"
        by(simp add: 1)
      thus ?thesis
        using ‹n = Suc n'› by(simp add: r01_binary_sum_def)
    qed
  qed
qed

lemma power2_e:
 "⋀e::real. 0 < e ⟹ ∃n::nat. real_of_rat (1/2)^n < e"
  by (simp add: real_arch_pow_inv)

lemma r01_binary_expression_converges_to_r:
  assumes "0 < r"
     and  "r < 1"
   shows "LIMSEQ (r01_binary_expression r)  r"
proof
  fix e :: real
  assume "0 < e"
  then obtain k :: nat where hk:"real_of_rat (1/2)^k < e"
    using power2_e by auto
  show "∀F x in sequentially. dist (r01_binary_expression r x) r < e"
  proof(rule eventually_sequentiallyI[of k])
    fix m
    assume "k ≤ m"
    have "¦ r - r01_binary_expression r m ¦ < e"
    proof (cases "r01_binary_expansion'' r m")
      case 1:(fields a ur lr)
      then have "¦r - r01_binary_expression r m¦ = ¦r - lr¦"
        by (metis r01_binary_expression_eq_lr snd_conv)
      also have "... = r - lr"
        using r01_binary_expansion_lr_r_ur[OF assms] 1        
        by (metis abs_of_nonneg diff_ge_0_iff_ge snd_conv)
      also have "... < e"
      proof -
        have "r - lr ≤ ur - lr"
          using r01_binary_expansion_lr_r_ur[of r] assms 1
          by (metis diff_right_mono fst_conv less_imp_le snd_conv)
        also have "... = (1/2)^(Suc m)"
          using r01_binary_expansion_diff[of r m]
          by(simp add: 1)
        also have "... ≤ (1/2)^(Suc k)"
          using ‹k ≤ m› by simp
        also have "... < (1/2)^k" by simp
        finally show ?thesis
          using hk by (simp add: of_rat_divide)
      qed
      finally show ?thesis .
    qed      
    then show "dist (r01_binary_expression r m) r < e"
      by (simp add: dist_real_def)
  qed
qed

lemma r01_binary_expression_correct:
  assumes "0 < r"
     and  "r < 1"
   shows "r = (∑n. real (r01_binary_expansion' r n) * (1/2)^(Suc n))"
proof -
  have "(λn. (λn. ∑i<n. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i) (Suc n)) = r01_binary_expression r"
  proof -
    have "⋀n. {..<Suc n} = {0..n}" by auto
    thus ?thesis
      by(auto simp add: r01_binary_expression_def r01_binary_sum_def)
  qed
  hence "LIMSEQ (λn. ∑i<n. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i)  r"
    using r01_binary_expression_converges_to_r[OF assms] LIMSEQ_imp_Suc[of "λn. ∑i<n. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i" r]
    by simp
  thus ?thesis
    using suminf_eq_lim[of "λn. real (r01_binary_expansion' r n) * (1/2)^(Suc n)"] assms limI[of "(λn. ∑i<n. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i)" r]
    by simp
qed


text ‹‹S0 ≤ S1 ≤ S2 ≤ ...›.›
lemma binary_sum_incseq:
   "incseq (r01_binary_sum a)"
  by(simp add: incseq_Suc_iff r01_binary_sum_def)

lemma r01_eq_iff:
  assumes "0 < r1" "r1 < 1"
          "0 < r2" "r2 < 1"
    shows "r1 = r2 ⟷ r01_binary_expansion' r1 = r01_binary_expansion' r2"
proof auto
  assume "r01_binary_expansion' r1 = r01_binary_expansion' r2"
  then have 1:"r01_binary_expression r1 = r01_binary_expression r2"
    using r01_binary_expansion'_expression_eq[of r1 r2] by simp
  have "r1 = lim (r01_binary_expression r1)"
    using limI[of _ r1] r01_binary_expression_converges_to_r[of r1] assms(1,2)
    by simp
  also have "... = lim (r01_binary_expression r2)"
    by (simp add: 1)
  also have "... = r2"
    using limI[of _ r2] r01_binary_expression_converges_to_r[of r2] assms(3,4)
    by simp
  finally show "r1 = r2" .
qed

lemma power_half_summable:
 "summable (λn. ((1::real) / 2) ^ Suc n)"
  using power_half_series summable_def by blast


lemma binary_expression_summable:
   assumes "⋀n. a n ∈ {0,1 :: nat}"
   shows "summable (λn. real (a n) * (1/2)^(Suc n))"
proof -
  have "summable (λn::nat. ¦real (a n) * ((1::real) / (2::real)) ^ Suc n¦)"
  proof(rule summable_rabs_comparison_test[of "λn. real (a n) * (1/2)^(Suc n)" "λn. (1/2)^(Suc n)"])
    have "⋀n. ¦real (a n) * (1 / 2) ^ Suc n¦ ≤ (1 / 2)^(Suc n)"
    proof -
      fix n
      have "¦real (a n) * (1 / 2) ^ Suc n¦ = real (a n) * (1 / 2) ^ Suc n"
        using assms by simp
      also have "... ≤ (1 / 2) ^ Suc n"
      proof -
        consider "a n = 0" | "a n = 1"
          using assms by (meson insertE singleton_iff)
        then show ?thesis
          by(cases,auto)
      qed
      finally show "¦real (a n) * (1 / 2) ^ Suc n¦ ≤ (1 / 2)^(Suc n)" .
    qed
    thus "∃N. ∀n≥N. ¦real (a n) * (1 / 2) ^ Suc n¦ ≤ (1 / 2) ^ Suc n"
      by simp
  next
    show "summable (λn. ((1::real) / 2) ^ Suc n)"
      using power_half_summable by simp
  qed
  thus ?thesis by simp
qed

lemma binary_expression_gteq0:
  assumes "⋀n. a n ∈ {0,1 :: nat}"
  shows "0 ≤ (∑n. real (a (n + k)) * (1 / 2) ^ Suc (n + k))"
proof -
  have "(∑n. 0) ≤ (∑n. real (a (n + k)) * (1 / 2) ^ Suc (n + k))"
    using binary_expression_summable[of a] summable_iff_shift[of "λn. real (a n) * (1 / 2) ^ Suc n" k] suminf_le[of "λn. 0" "λn. real (a (n + k)) * (1 / 2) ^ Suc (n + k)"] assms
    by simp
  thus ?thesis by simp
qed

lemma binary_expression_leeq1:
  assumes "⋀n. a n ∈ {0,1 :: nat}"
  shows "(∑n. real (a (n + k)) * (1 / 2) ^ Suc (n + k)) ≤ 1"
proof -
  have "(∑n. real (a (n + k)) * (1 / 2) ^ Suc (n + k)) ≤ (∑n. (1/2)^(Suc n))"
  proof(rule suminf_le)
    fix n
    have 1:"real (a (n + k)) * (1 / 2) ^ Suc (n + k) ≤ (1 / 2) ^ Suc (n + k)"
      using assms[of "n+k"] by auto
    have 2:"((1::real) / 2) ^ Suc (n + k) ≤ (1 / 2) ^ Suc n"
      by simp
    show "real (a (n + k)) * (1 / 2) ^ Suc (n + k) ≤ (1 / 2) ^ Suc n"
      by(rule order.trans[OF 1 2])
  next
    show "summable (λn. real (a (n + k)) * (1 / 2) ^ Suc (n + k))"
      using binary_expression_summable[of a] summable_iff_shift[of "λn. real (a n) * (1 / 2) ^ Suc n" k] assms
      by simp
  next
    show "summable (λn. ((1::real) / 2) ^ Suc n)"
      using power_half_summable by simp
  qed
  thus ?thesis
    using power_half_series sums_unique by fastforce
qed

lemma binary_expression_less_than:
  assumes "⋀n. a n ∈ {0,1 :: nat}"
  shows "(∑n. real (a (n + k)) * (1 / 2) ^ Suc (n + k)) ≤ (∑n. (1 / 2) ^ Suc (n + k))"
proof(rule suminf_le)
  fix n
  show "real (a (n + k)) * (1 / 2) ^ Suc (n + k) ≤ (1 / 2) ^ Suc (n + k)"
    using assms[of "n + k"] by auto
next
  show "summable (λn. real (a (n + k)) * (1 / 2) ^ Suc (n + k))"
    using summable_iff_shift[of "λn. real (a n) * (1 / 2) ^ Suc n" k] binary_expression_summable[of a] assms
    by simp
next
  show "summable (λn. ((1::real) / 2) ^ Suc (n + k))"
    using power_half_summable summable_iff_shift[of "λn. ((1::real) / 2) ^ Suc n" k]
    by simp
qed

lemma lim_sum_ai:
  assumes "⋀n. a n ∈ {0,1 :: nat}"
  shows "lim (λn. (∑i=0..n. real (a i) * (1/2)^(Suc i))) = (∑n::nat. real (a n) * (1/2)^(Suc n))"
proof -
  have "⋀n::nat. {0..n} = {..n}" by auto
  hence "LIMSEQ (λn. ∑i=0..n. real (a i) * (1 / 2) ^ Suc i) (∑n. real (a n) * (1 / 2) ^ Suc n)"
    using summable_LIMSEQ'[of "λn. real (a n) * (1/2)^(Suc n)"] binary_expression_summable[of a] assms
    by simp
  thus "lim (λn. (∑i=0..n. real (a i) * (1/2)^(Suc i))) = (∑n. real (a n) * (1 / 2) ^ Suc n)"
    using limI by simp
qed

lemma half_1_minus_sum:
 "1 - (∑i<k. ((1::real) / 2) ^ Suc i) = (1/2)^k"
  by(induction k) auto

lemma half_sum:
  "(∑n. ((1::real) / 2) ^ (Suc (n + k))) = (1/2)^k"
  using suminf_split_initial_segment[of "λn. ((1::real) / 2) ^ (Suc n)" k] half_1_minus_sum[of k] power_half_series sums_unique[of "λn. (1 / 2) ^ Suc n" 1] power_half_summable
  by fastforce

lemma ai_exists0_less_than_sum:
  assumes "⋀n. a n ∈ {0,1}"
          "i ≥ m"
      and "a i = 0"
    shows "(∑n::nat. real (a (n + m)) * (1/2)^(Suc (n + m))) < (1 / 2) ^ m"
proof -
  have "(∑n::nat. real (a (n + m)) * (1/2)^(Suc (n + m))) = (∑n<i-m. real (a (n + m)) * (1/2)^(Suc (n + m))) + (∑n::nat. real (a (n + i)) * (1/2)^(Suc (n + i)))"
    using suminf_split_initial_segment[of "λn. real (a (n + m)) * (1/2)^(Suc (n + m))" "i-m"] assms(1) binary_expression_summable[of a] summable_iff_shift[of "λn. real (a n) * (1 / 2) ^ Suc n" m] assms(2)
    by simp
  also have "... < (1 / 2) ^ m"
  proof -
    have "(∑n. real (a (n + i)) * (1 / 2) ^ Suc (n + i)) ≤ (1 / 2) ^ Suc i"
    proof -
      have "(∑n::nat. real (a (n + i)) * (1/2)^(Suc (n + i))) = (∑n::nat. real (a (Suc n + i)) * (1/2)^(Suc (Suc n + i)))"
        using suminf_split_head[of "λn. real (a (n + i)) * (1/2)^(Suc (n + i))"] assms(1,3) binary_expression_summable[of a] summable_iff_shift[of "λn. real (a n) * (1 / 2) ^ Suc n" i]
        by simp
      also have "... = (∑n::nat. real (a (n + Suc i)) * (1/2)^(Suc n + Suc i))"
        by simp
      also have "... ≤ (∑n::nat. (1/2)^(Suc n + Suc i))"
        using binary_expression_less_than[of a "Suc i"] assms(1)
        by simp
      also have "... = (1/2)^(Suc i)"
        using half_sum[of "Suc i"] by simp
      finally show ?thesis .
    qed
    moreover have "(∑n<i - m. real (a (n + m)) * (1 / 2) ^ Suc (n + m)) ≤ (1/2)^m - (1/2)^i"
    proof -
      have "(∑n<i - m. real (a (n + m)) * (1 / 2) ^ Suc (n + m)) ≤ (∑n<i - m. (1 / 2) ^ Suc (n + m))"
      proof -
        have "real (a i) * (1 / 2) ^ Suc i ≤ (1 / 2) ^ Suc i" for i
          using assms(1)[of i] by auto
        thus ?thesis
          by (simp add: sum_mono)
      qed
      also have "... = (∑n. (1 / 2) ^ Suc (n + m)) - (∑n. (1 / 2) ^ Suc (n + (i - m) + m))"
        using suminf_split_initial_segment[of "λn. (1 / 2) ^ Suc (n + m)" "i-m"] power_half_summable summable_iff_shift[of "λn. ((1::real) / 2) ^ Suc n" m]
        by fastforce
      also have "... = (∑n. (1 / 2) ^ Suc (n + m)) - (∑n. (1 / 2) ^ Suc (n + i))"
        using assms(2) by simp
      also have "... = (1/2)^m - (1/2)^i"
        using half_sum by fastforce
      finally show ?thesis .
    qed
    ultimately have "(∑n<i - m. real (a (n + m)) * (1 / 2) ^ Suc (n + m)) + (∑n. real (a (n + i)) * (1 / 2) ^ Suc (n + i)) ≤ (1 / 2) ^ Suc i + (1 / 2) ^ m - (1 / 2) ^ i"
      by linarith
    also have "... < (1 / 2) ^ m "
      by simp
    finally show ?thesis .
  qed
  finally show ?thesis .
qed

lemma ai_exists0_less_than1:
  assumes "⋀n. a n ∈ {0,1}"
      and "∃i. a i = 0"
    shows "(∑n::nat. real (a n) * (1/2)^(Suc n)) < 1"
  using ai_exists0_less_than_sum[of a 0] assms
  by auto

lemma ai_1_gt:
  assumes "⋀n. a n ∈ {0,1}"
      and "a i = 1"
    shows "(1/2)^(Suc i) ≤ (∑n::nat. real (a (n+i)) * (1/2)^(Suc (n+i)))"
proof -
  have 1:"(∑n::nat. real (a (n+i)) * (1/2)^(Suc (n+i))) = (1 / 2) ^ Suc (0 + i) + (∑n. real (a (Suc n + i)) * (1 / 2) ^ Suc (Suc n + i))"
    using suminf_split_head[of "λn. real (a (n+i)) * (1/2)^(Suc (n+i))"] binary_expression_summable[of a] summable_iff_shift[of "λn. real (a n) * (1 / 2) ^ Suc n" i] assms
    by simp
  show ?thesis
    using 1 binary_expression_gteq0[of a "Suc i"] assms(1)
    by simp
qed

lemma ai_exists1_gt0:
  assumes "⋀n. a n ∈ {0,1}"
      and "∃i. a i = 1"
    shows "0 < (∑n::nat. real (a n) * (1/2)^(Suc n))"
proof -
  obtain k where h1: "a k = 1"
    using assms(2) by auto
  have "(1/2)^(Suc k) = (∑n::nat. (if n = k then (1/2)^(Suc k) else (0::real)))"
  proof -
    have "(λn. if n ∈ {k} then (1 / 2) ^ Suc k else (0::real)) = (λn. if n = k then (1/2)^(Suc k) else 0)"
      by simp
    moreover have "(λn. if n ∈ {k} then (1 / 2) ^ Suc k else (0::real)) sums (∑r∈{k}. (1 / 2) ^ Suc k)"
      using sums_If_finite_set[of "{k}" "λn. ((1::real)/2)^(Suc k)"] by simp
    ultimately have "(λn. if n = k then (1 / 2) ^ Suc k else (0::real)) sums (1/2)^(Suc k)"
      by simp
    thus ?thesis
      using sums_unique[of "λn. if n = k then (1 / 2) ^ Suc k else (0::real)" "(1/2)^(Suc k)"]
      by simp
  qed
  also have "(∑n::nat. (if n = k then (1/2)^(Suc k) else 0)) ≤ (∑n::nat. real (a n) * (1/2)^(Suc n))"
  proof(rule suminf_le)
    show "⋀n. (if n = k then (1 / 2) ^ Suc k else 0) ≤ real (a n) * (1 / 2) ^ Suc n"
    proof -
      fix n
      show "(if n = k then (1 / 2) ^ Suc k else 0) ≤ real (a n) * (1 / 2) ^ Suc n"
        by(cases "n = k"; simp add: h1)
    qed
  next
    show "summable (λn. if n = k then (1 / 2) ^ Suc k else (0::real))"
      using summable_single[of k "λn. ((1::real) / 2) ^ Suc k"]
      by simp
  next
    show "summable (λn. real (a n) * (1 / 2) ^ Suc n)"
      using binary_expression_summable[of a] assms(1)
      by simp
  qed
  finally have "(1 / 2) ^ Suc k ≤ (∑n. real (a n) * (1 / 2) ^ Suc n)" .
  moreover have "0 < ((1::real) / 2) ^ Suc k" by simp
  ultimately show ?thesis by linarith
qed


lemma r01_binary_expression_ex0:
  assumes "0 < r" "r < 1"
  shows "∃i.  r01_binary_expansion' r i = 0"
proof (rule ccontr)
  assume "¬ (∃ i. r01_binary_expansion' r i = 0)"
  then have "⋀i. r01_binary_expansion' r i = 1"
    using real01_binary_expansion'_0or1[of r] by blast
  hence 1:"r01_binary_expression r = (λn. ∑i=0..n. ((1/2)^(Suc i)))"
    by(auto simp: r01_binary_expression_def r01_binary_sum_def)
  have "LIMSEQ (r01_binary_expression r)  1"
  proof -
    have "LIMSEQ (λn. ∑i=0..n. (((1::real)/2)^(Suc i))) 1"
      using power_half_series sums_def'[of "λn. ((1::real)/2)^(Suc n)" 1]
      by simp
    thus ?thesis
      using 1 by simp
  qed
  moreover have "LIMSEQ (r01_binary_expression r) r"
    using r01_binary_expression_converges_to_r[of r] assms
    by simp
  ultimately have "r = 1"
    using LIMSEQ_unique by auto
  thus False
    using assms by simp
qed

lemma r01_binary_expression_ex1:
  assumes "0 < r" "r < 1"
  shows "∃i.  r01_binary_expansion' r i = 1"
proof (rule ccontr)
  assume "¬ (∃i. r01_binary_expansion' r i = 1)"
  then have "⋀i. r01_binary_expansion' r i = 0"
    using real01_binary_expansion'_0or1[of r] by blast
  hence 1:"r01_binary_expression r = (λn. ∑i=0..n. 0)"
    by(auto simp add: r01_binary_expression_def r01_binary_sum_def)
  hence "LIMSEQ (r01_binary_expression r) 0"
    by simp
  moreover have "LIMSEQ (r01_binary_expression r) r"
    using r01_binary_expression_converges_to_r[of r] assms
    by simp
  ultimately have "r = 0"
    using LIMSEQ_unique by auto
  thus False
    using assms by simp
qed

lemma r01_binary_expansion'_gt1:
  "1 ≤ r ⟷ (∀n. r01_binary_expansion' r n = 1)"
proof auto
  fix n
  assume h:"1 ≤ r"
  show "r01_binary_expansion' r n = Suc 0"
    unfolding r01_binary_expansion'_def
  proof(cases n)
    case 0
    then show "fst (r01_binary_expansion'' r n) = Suc 0"
      using h by simp
  next
    case 2:(Suc n')
    show "fst (r01_binary_expansion'' r n) = Suc 0"
    proof(cases "r01_binary_expansion'' r n'")
      case 3:(fields a ur lr)
      then have "(ur + lr) / 2 ≤ 1"
        using r01_binary_expansion_lr_ur_nn[of r "Suc n'"]
        by (cases "((ur + lr) / 2) ≤ r") (auto simp: Let_def) 
      thus "fst (r01_binary_expansion'' r n) = Suc 0"
        using h by(simp add: 2 3 Let_def)
    qed
  qed
next
  assume h:"∀n. r01_binary_expansion' r n = Suc 0"
  show "1 ≤ r"
  proof(rule ccontr)
    assume "¬ 1 ≤ r"
    then consider "r ≤ 0" | "0 < r ∧ r < 1"
      by linarith
    then show "False"
    proof cases
      case 1
      then have "r01_binary_expansion' r 0 = 0"
        by(simp add: r01_binary_expansion'_def)
      then show ?thesis
        using h by simp
    next
      case 2
      then have "∃i.  r01_binary_expansion' r i = 0"
        using r01_binary_expression_ex0[of r] by simp
      then show ?thesis
        using h by simp
    qed
  qed
qed

lemma r01_binary_expansion'_lt0:
 "r ≤ 0 ⟷ (∀n. r01_binary_expansion' r n = 0)"
proof auto
  fix n
  assume h:"r ≤ 0"
  show "r01_binary_expansion' r n = 0"
  proof(cases n)
    case 0
    then show ?thesis
      using h by(simp add: r01_binary_expansion'_def)
  next
    case hn:(Suc n')
    then show ?thesis
      unfolding r01_binary_expansion'_def
    proof(cases "r01_binary_expansion'' r n'")
      case 1:(fields a ur lr)
      then have "0 < ((ur + lr) / 2)"
        using r01_binary_expansion_lr_ur_nn[of r n']
        by simp
      hence "r < ..."
        using h by linarith       
      then show "fst (r01_binary_expansion'' r n) = 0 "
        by(simp add: 1 hn Let_def)
    qed
  qed
next
  assume h:"∀n. r01_binary_expansion' r n = 0"
  show "r ≤ 0"
  proof(rule ccontr)
    assume "¬ r ≤ 0"
    then consider "0 < r ∧ r < 1" | "1 ≤ r" by linarith
    thus False
    proof cases
      case 1
      then have "∃i. r01_binary_expansion' r i = 1"
        using r01_binary_expression_ex1[of r] by simp
      then show ?thesis
        using h by simp
    next
      case 2
      then show ?thesis
        using r01_binary_expansion'_gt1[of r] h by simp
    qed
  qed
qed
    

text ‹The sequence $111111\dots$ does not appear in $r = 0.a_1 a_2\dots$. ›
lemma r01_binary_expression_ex0_strong:
  assumes "0 < r" "r < 1"
  shows "∃i≥n. r01_binary_expansion' r i = 0"
proof(cases "r01_binary_expansion'' r n")
  case 1:(fields a ur lr)
  show ?thesis
  proof(rule ccontr)
    assume "¬ (∃i≥n. r01_binary_expansion' r i = 0)"
    then have h:"∀i≥n. r01_binary_expansion' r i = 1"
      using real01_binary_expansion'_0or1[of r] by blast
    
    have "r = (∑i=0..n. real (r01_binary_expansion' r i) * ((1/2)^(Suc i))) + (∑i::nat. real (r01_binary_expansion' r (i + (Suc n))) * ((1/2)^(Suc (i + (Suc n)))))"
    proof -
      have "r = (∑l. real (r01_binary_expansion' r l) * (1 / 2) ^ Suc l)"
        using r01_binary_expression_correct[of r] assms by simp
      also have "... = (∑l. real (r01_binary_expansion' r (l + Suc n)) * (1 / 2) ^ Suc (l + Suc n)) + (∑i<Suc n. real (r01_binary_expansion' r i) * (1 / 2) ^ Suc i)"
        apply(rule suminf_split_initial_segment)
        apply(rule binary_expression_summable)
        using real01_binary_expansion'_0or1[of r] by simp
      also have "... = (∑i=0..n. real (r01_binary_expansion' r i) * ((1/2)^(Suc i))) + (∑i::nat. real (r01_binary_expansion' r (i + (Suc n))) * ((1/2)^(Suc (i + (Suc n)))))"
      proof -
        have "⋀n. {..<Suc n} = {0..n}" by auto
        thus ?thesis by simp
      qed
      finally show ?thesis .
    qed
    also have "... = (∑i=0..n. real (r01_binary_expansion' r i) * ((1/2)^(Suc i))) + (∑i::nat. ((1/2)^(Suc (i + (Suc n)))))"
      using h by simp
    also have "... = (∑i=0..n. real (r01_binary_expansion' r i) * ((1/2)^(Suc i))) + (1/2)^(Suc n)"
      using half_sum[of "Suc n"] by simp
    also have "... = lr + (1/2)^(Suc n)"
      using 1 r01_binary_expression_eq_lr[of r n]
      by(simp add: r01_binary_expression_def r01_binary_sum_def)
    also have "... = ur"
      using r01_binary_expansion_diff[of r n]
      by(simp add: 1)
    finally have "r = ur" .
    moreover have "r < ur"
      using r01_binary_expansion_lr_r_ur[of r n] assms 1
      by simp
    ultimately show False
      by simp
  qed
qed

text ‹ A binary expression is well-formed when $111\dots$ does not appear in the tail of the sequence ›
definition biexp01_well_formed :: "(nat ⇒ nat) ⇒ bool" where
"biexp01_well_formed a ≡ (∀n. a n ∈ {0,1}) ∧ (∀n. ∃m≥n. a m = 0)"

lemma biexp01_well_formedE:
  assumes "biexp01_well_formed a"
  shows "(∀n. a n ∈ {0,1}) ∧ (∀n. ∃m≥n. a m = 0)"
  using assms by(simp add: biexp01_well_formed_def)

lemma biexp01_well_formedI:
  assumes "⋀n. a n ∈ {0,1}"
      and "⋀n. ∃m≥n. a m = 0"
    shows "biexp01_well_formed a"
  using assms by(simp add: biexp01_well_formed_def)

lemma r01_binary_expansion_well_formed:
  assumes "0 < r" "r < 1"
  shows "biexp01_well_formed (r01_binary_expansion' r)"
  using r01_binary_expression_ex0_strong[of r] assms real01_binary_expansion'_0or1[of r]
  by(simp add: biexp01_well_formed_def)

lemma biexp01_well_formed_comb:
  assumes "biexp01_well_formed a"
      and "biexp01_well_formed b"
    shows "biexp01_well_formed (λn. if even n then a (n div 2)
                                              else b ((n-1) div 2))"
proof(rule biexp01_well_formedI)
  show "⋀n. (if even n then a (n div 2) else b ((n - 1) div 2)) ∈ {0, 1}"
    using assms biexp01_well_formedE by simp
next
  fix n
  obtain m where 1:"m≥n ∧ a m = 0"
    using assms biexp01_well_formedE by blast
  then have "a ((2*m) div 2) = 0" by simp
  hence "(if even (2*m) then a (2*m div 2) else b ((2*m - 1) div 2)) = 0"
    by simp
  moreover have "2*m ≥ n" using 1 by simp
  ultimately show "∃m≥n. (if even m then a (m div 2) else b ((m - 1) div 2)) = 0"
    by auto
qed



lemma nat_complete_induction:
  assumes "P (0 :: nat)"
      and "⋀n. (⋀m. m ≤ n ⟹ P m) ⟹ P (Suc n)"
    shows "P n"
proof(cases n)
  case 0
  then show ?thesis
    using assms(1) by simp
next
  case h:(Suc n')
  have "P (Suc n')"
  proof(rule assms(2))
    show "⋀m. m ≤ n' ⟹ P m"
    proof(induction n')
      case 0
      then show ?case
        using assms(1) by simp
    next
      case (Suc n'')
      then show ?case
        by (metis assms(2) le_SucE)
    qed
  qed
  thus ?thesis
    using h by simp
qed

text ‹ ‹(∑m. real (a m) * (1 / 2) ^ Suc m) n = a n›.›
lemma biexp01_well_formed_an:
  assumes "biexp01_well_formed a"
  shows "r01_binary_expansion' (∑m. real (a m) * (1 / 2) ^ Suc m) n = a n"
proof(rule nat_complete_induction[of _ n])
  show "r01_binary_expansion' (∑m. real (a m) * (1 / 2) ^ Suc m) 0 = a 0"
  proof (auto simp add: r01_binary_expansion'_def)
    assume h:"1 ≤ (∑m. real (a m) * (1 / 2) ^ m / 2) * 2"
    show "Suc 0 = a 0"
    proof(rule ccontr)
      assume "Suc 0 ≠ a 0"
      then have "a 0 = 0"
        using assms(1) biexp01_well_formedE[of a] by auto
      hence "(∑m. real (a m) * (1 / 2) ^ (Suc m)) = (∑m. real (a (Suc m)) * (1 / 2) ^ (Suc (Suc m)))"
        using suminf_split_head[of "λm. real (a m) * (1 / 2) ^ (Suc m)"] binary_expression_summable[of a] assms biexp01_well_formedE
        by simp
      also have "... < 1/2"
        using ai_exists0_less_than_sum[of a 1] assms biexp01_well_formedE[of a]
        by auto
      finally have "(∑m. real (a m) * (1 / 2) ^ m / 2) < 1/2"
        by simp
      thus False
        using h by simp
    qed
  next
    assume h:"¬ 1 ≤ (∑m. real (a m) * (1 / 2) ^ m / 2) * 2"
    show "a 0 = 0"
    proof(rule ccontr)
      assume "a 0 ≠ 0"
      then have "a 0 = 1"
        using assms(1) biexp01_well_formedE[of a]
        by (meson insertE singletonD)
      hence "1/2 ≤ (∑m. real (a m) * (1 / 2) ^ (Suc m))"
        using ai_1_gt[of a 0] assms(1) biexp01_well_formedE[of a]
        by auto
      thus False
        using h by simp
    qed
  qed
next
  fix n :: nat
  assume ih:"(⋀m. m ≤ n ⟹ r01_binary_expansion' (∑m. real (a m) * (1 / 2) ^ Suc m) m = a m)"
  show "r01_binary_expansion' (∑m. real (a m) * (1 / 2) ^ Suc m) (Suc n) = a (Suc n)"
  proof(cases "r01_binary_expansion'' (∑m. real (a m) * (1 / 2) ^ Suc m) n")
    case h:(fields bn ur lr)
    then have hlr:"lr = (∑k=0..n. real (a k) * (1 / 2) ^ Suc k)"
      using r01_binary_expression_eq_lr[of "∑m. real (a m) * (1 / 2) ^ Suc m" n] ih
      by(simp add: r01_binary_expression_def r01_binary_sum_def)
    have hlr2:"(ur + lr) / 2 = lr + (1/2)^(Suc (Suc n))"
    proof -
      have "(ur + lr) / 2 = lr + (1/2)^(Suc (Suc n))"
        using r01_binary_expansion_diff[of "∑m. real (a m) * (1 / 2) ^ Suc m" n] h by simp
      show ?thesis
        by (simp add: ‹(ur + lr) / 2 = lr + (1 / 2) ^ Suc (Suc n)› of_rat_add of_rat_divide of_rat_power)
    qed
    show ?thesis
      using h
    proof(auto simp add: r01_binary_expansion'_def Let_def)
      assume h1: "(ur + lr) ≤ (∑m. real (a m) * (1 / 2) ^ m / 2) * 2"
      show "Suc 0 = a (Suc n)"
      proof(rule ccontr)
        assume "Suc 0 ≠ a (Suc n)"
        then have "a (Suc n) = 0"
          using assms(1) biexp01_well_formedE[of a] by auto
        have "(∑m. real (a m) * (1 / 2) ^ m / 2) < (∑k=0..n. real (a k) * (1 / 2) ^ Suc k) + (1/2)^(Suc (Suc n))"
        proof -
          have "(∑m. real (a m) * (1 / 2) ^ (Suc m)) = (∑k=0..n. real (a k) * (1 / 2) ^ Suc k) + (∑m. real (a (m+Suc n)) * (1 / 2) ^ Suc (m + Suc n))"
          proof -
            have "{0..n} = {..<Suc n}" by auto
            thus ?thesis
              using suminf_split_initial_segment[of "λm. real (a m) * (1 / 2) ^ (Suc m)" "Suc n"] binary_expression_summable[of a] assms(1) biexp01_well_formedE[of a]
              by simp
          qed
          also have "... = (∑k=0..n. real (a k) * (1 / 2) ^ Suc k) + (∑m. real (a (Suc m + Suc n)) * (1 / 2) ^ Suc (Suc m + Suc n))"
            using suminf_split_head[of "λm. real (a (m + Suc n)) * (1 / 2) ^ (Suc (m + Suc n))"] binary_expression_summable[of a] assms(1) biexp01_well_formedE[of a] Series.summable_iff_shift[of "λm. real (a m) * (1 / 2) ^ (Suc m)" "Suc n"] ‹a (Suc n) = 0›
            by simp
          also have "... = (∑k=0..n. real (a k) * (1 / 2) ^ Suc k) + (∑m. real (a (m + Suc (Suc n))) * (1 / 2) ^ Suc (m + Suc (Suc n)))"
            by simp
          also have "... < (∑k=0..n. real (a k) * (1 / 2) ^ Suc k) + (1/2)^Suc (Suc n)"
            using ai_exists0_less_than_sum[of a "Suc (Suc n)"] assms(1) biexp01_well_formedE[of a]
            by auto
          finally show ?thesis by simp
        qed
        thus False
          using h1 hlr2 hlr by simp
      qed
    next
      assume h2:"¬ ur + lr ≤ (∑m. real (a m) * (1 / 2) ^ m / 2) * 2"
      show "a (Suc n) = 0"
      proof(rule ccontr)
        assume "a (Suc n) ≠ 0"
        then have "a (Suc n) = 1"
          using biexp01_well_formedE[OF assms(1)]
          by (meson insertE singletonD)
        have "(∑k=0..n. real (a k) * (1 / 2) ^ Suc k) + (1/2)^(Suc (Suc n)) ≤ (∑m. real (a m) * (1 / 2) ^ m / 2)"
        proof -
          have "(∑m. real (a m) * (1 / 2) ^ (Suc m)) = (∑k=0..n. real (a k) * (1 / 2) ^ Suc k) + (∑m. real (a (m+Suc n)) * (1 / 2) ^ Suc (m + Suc n))"
          proof -
            have "{0..n} = {..<Suc n}" by auto
            thus ?thesis
              using suminf_split_initial_segment[of "λm. real (a m) * (1 / 2) ^ (Suc m)" "Suc n"] binary_expression_summable[of a] assms(1) biexp01_well_formedE[of a]
              by simp
          qed
          also have "... = (∑k=0..n. real (a k) * (1 / 2) ^ Suc k) + (∑m. real (a (Suc m + Suc n)) * (1 / 2) ^ Suc (Suc m + Suc n)) + (1 / 2) ^ Suc (Suc n)"
            using suminf_split_head[of "λm. real (a (m + Suc n)) * (1 / 2) ^ (Suc (m + Suc n))"] binary_expression_summable[of a] assms(1) biexp01_well_formedE[of a] Series.summable_iff_shift[of "λm. real (a m) * (1 / 2) ^ (Suc m)" "Suc n"] ‹a (Suc n) = 1›
            by simp
          also have "... = (∑k=0..n. real (a k) * (1 / 2) ^ Suc k) + (∑m. real (a (m + Suc (Suc n))) * (1 / 2) ^ Suc (m + (Suc (Suc n)))) + (1 / 2) ^ Suc (Suc n)"
            by simp
          also have "... ≥ (∑k=0..n. real (a k) * (1 / 2) ^ Suc k) + (1 / 2) ^ Suc (Suc n)"
            using binary_expression_gteq0[of a "Suc (Suc n)"] assms(1) biexp01_well_formedE[of a] by simp
          finally show ?thesis by simp
        qed
        thus False
          using h2 hlr2 hlr by simp
      qed
    qed
  qed
qed


lemma f01_borel_measurable:
  assumes "f -` {0::real} ∈ sets real_borel"
          "f -` {1} ∈ sets borel"
      and "⋀r::real. f r ∈ {0,1}"
    shows "f ∈ borel_measurable real_borel"
proof(rule measurableI)
  fix U :: "real set"
  assume "U ∈ sets borel"
  consider "1 ∈ U ∧ 0 ∈ U" | "1 ∈ U ∧ 0 ∉ U" | "1 ∉ U ∧ 0 ∈ U" | "1 ∉ U ∧ 0 ∉ U"
    by auto
  then show "f -` U ∩ space real_borel ∈ sets borel"
  proof cases
    case 1
    then have "f -` U = UNIV"
      using assms(3) by auto
    then show ?thesis by simp
  next
    case 2
    then have "f -` U = f -` {1}"
      using assms(3) by fastforce
    then show ?thesis
      using assms(2) by simp
  next
    case 3
    then have "f -` U = f -` {0}"
      using assms(3) by fastforce
    then show ?thesis
      using assms(1) by simp
  next
    case 4
    then have "f -` U = {}"
      using assms(3) by (metis all_not_in_conv insert_iff vimage_eq)
    then show ?thesis by simp
  qed
qed simp


lemma r01_binary_expansion'_measurable:
 "(λr. real (r01_binary_expansion' r n)) ∈ borel_measurable (borel :: real measure)"
proof -
  have "(λr. real (r01_binary_expansion' r n)) -`{0} ∈ sets borel ∧ (λr. real (r01_binary_expansion' r n)) -`{1} ∈ sets borel"
  proof -
    let ?A = "{..0::real} ∪ (⋃i∈{l::nat. l < 2^(Suc n) ∧ even l} . {i/2^(Suc n)..<(Suc i)/2^(Suc n)})"
    let ?B = "{1::real..} ∪ (⋃i∈{l::nat. l < 2^(Suc n) ∧ odd l} .  {i/2^(Suc n)..<(Suc i)/2^(Suc n)})"
    have "?A ∈ sets borel" by simp
    have "?B ∈ sets borel" by simp
    have hE:"?A ∩ ?B = {}"
    proof auto
      fix r :: real
      fix l :: nat
      assume h: "r ≤ 0"
                "odd l"
                "real l / (2 * 2 ^ n) ≤ r"
      then have "0 < l" by(cases l; auto)
      hence "0 < real l / (2 * 2 ^ n)" by simp
      thus False
        using h by simp
    next
      fix r :: real
      fix l :: nat
      assume h: "l < 2 * 2 ^ n"
                "even l"
                "1 ≤ r"
                "r < (1 + real l) / (2 * 2 ^ n)"
      then have "1 + real l ≤ 2 * 2 ^ n"
        by (simp add: nat_less_real_le)
      moreover have "1 + real l ≠ 2 * 2 ^ n"
        using h by auto
      ultimately have "1 + real l < 2 * 2 ^ n" by simp
      hence "(1 + real l) / (2 * 2 ^ n) < 1" by simp
      thus False using h by linarith
    next
      fix r :: real
      fix l1 l2 :: nat
      assume h: "even l1" "odd l2"
                "real l1 / (2 * 2 ^ n) ≤ r" "r < (1 + real l1) / (2 * 2 ^ n)"
                "real l2 / (2 * 2 ^ n) ≤ r" "r < (1 + real l2) / (2 * 2 ^ n)"
      then consider "l1 < l2" | "l2 < l1"  by fastforce
      thus False
      proof cases
        case 1
        then have "(1 + real l1) / (2 * 2 ^ n) ≤ real l2 / (2 * 2 ^ n)"
          by (simp add: frac_le)
        then show ?thesis
          using h by simp
      next
        case 2
        then have "(1 + real l2) / (2 * 2 ^ n) ≤ real l1 / (2 * 2 ^ n)"
          by (simp add: frac_le)
        then show ?thesis
          using h by simp
      qed
    qed
    have hU:"?A ∪ ?B = UNIV"
    proof
      show "?A ∪ ?B ⊆ UNIV" by simp
    next
      show "UNIV ⊆ ?A ∪ ?B"
      proof
        fix r :: real
        consider "r ≤ 0" | "0 < r ∧ r < 1" | "1 ≤ r" by linarith
        then show "r ∈ ?A ∪ ?B"
        proof cases
          case 1
          then show ?thesis by simp
        next
          case 2
          show ?thesis
          proof(cases "r01_binary_expansion'' r n")
            case hc:(fields a ur lr)
            then have hlu:"lr ≤ r ∧ r < ur"
              using 2 r01_binary_expansion_lr_r_ur[of r n] by simp
            obtain k :: nat where hk:
             "lr = real k / 2 ^ Suc n ∧ k < 2 ^ Suc n"
              using r01_binary_expression'_sum_range[of r n] hc
              by auto
            hence "ur = real (Suc k) / 2^Suc n"
              using r01_binary_expansion_diff[of r n] hc
              by (simp add: add_divide_distrib power_one_over)
            thus ?thesis
              using hlu hk by auto
          qed
        next
          case 3
          then show ?thesis by simp
        qed
      qed
    qed
    have hi1:"- ?A = ?B"
    proof -
      have "?B ⊆ - ?A"
        using hE by blast
      moreover have "-?A ⊆ ?B"
      proof -
        have "-(?A ∪ ?B) = {}"
          using hU by simp
        hence "(-?A) ∩ (-?B) = {}" by simp
        thus ?thesis
          by blast
      qed
      ultimately show ?thesis
        by blast
    qed
    have hi2: "?A = -?B"
      using hi1 by blast

    let ?U0 = "(λr. real (r01_binary_expansion' r n)) -`{0}"
    let ?U1 = "(λr. real (r01_binary_expansion' r n)) -`{1}"

    have hU':"?U0 ∪ ?U1 = UNIV"
    proof -
      have "?U0 ∪ ?U1 = (λr. real (r01_binary_expansion' r n)) -`{0,1}"
        by auto
      thus ?thesis
        using real01_binary_expansion'_0or1[of _ n] by auto
    qed
    have hE':"?U0 ∩ ?U1 = {}"
      by auto

    have hiu1:"- ?U0 = ?U1"
      using hE' hU' by fastforce

    have hiu2:"- ?U1 = ?U0"
      using hE' hU' by fastforce

    have "?U0 ⊆ ?A"
    proof
      fix r
      assume "r ∈ ?U0"
      then have h1:"r01_binary_expansion' r n = 0"
        by simp
      then consider "r ≤ 0" | "0 < r ∧ r < 1"
        using r01_binary_expansion'_gt1[of r] by fastforce
      thus "r ∈ ?A"
      proof cases
        case 1
        then show ?thesis by simp
      next
        case 2
        then have 3:"(snd (snd (r01_binary_expansion'' r n))) ≤ r ∧
                     r < (fst (snd (r01_binary_expansion'' r n)))"
          using r01_binary_expansion_lr_r_ur[of r n] by simp
        obtain k where 4: 
          "(snd (snd (r01_binary_expansion'' r n))) =
           real k / 2 ^ Suc n ∧
           k < 2 ^ Suc n ∧ even k"
          using r01_binary_expression'_sum_range[of r n] h1
          by auto
        have "(fst (snd (r01_binary_expansion'' r n))) = real (Suc k) / 2 ^ Suc n"
        proof -
          have "(fst (snd (r01_binary_expansion'' r n))) = (snd (snd (r01_binary_expansion'' r n))) + (1/2)^Suc n"
            using r01_binary_expansion_diff[of r n] by linarith
          thus ?thesis
            using 4
            by (simp add: add_divide_distrib power_one_over)
        qed
        thus ?thesis
          using 3 4 by auto
      qed
    qed

    have "?U1 ⊆ ?B"
    proof
      fix r
      assume "r ∈ ?U1"
      then have h1:"r01_binary_expansion' r n = 1"
        by simp
      then consider "1 ≤ r" | "0 < r ∧ r < 1"
        using r01_binary_expansion'_lt0[of r] by fastforce
      thus "r ∈ ?B"
      proof cases
        case 1
        then show ?thesis by simp
      next
        case 2
        then have 3:"(snd (snd (r01_binary_expansion'' r n))) ≤ r ∧
                     r < (fst (snd (r01_binary_expansion'' r n)))"
          using r01_binary_expansion_lr_r_ur[of r n] by simp
        obtain k where 4: 
          "(snd (snd (r01_binary_expansion'' r n))) =
           real k / 2 ^ Suc n ∧
           k < 2 ^ Suc n ∧ odd k"
          using StandardBorel.r01_binary_expression'_sum_range[of r n] h1
          by auto
        have "(fst (snd (r01_binary_expansion'' r n))) = real (Suc k) / 2 ^ Suc n"
        proof -
          have "(fst (snd (r01_binary_expansion'' r n))) = (snd (snd (r01_binary_expansion'' r n))) + (1/2)^Suc n"
            using r01_binary_expansion_diff[of r n] by simp
          thus ?thesis
            using 4
            by (simp add: add_divide_distrib power_one_over)
        qed
        thus ?thesis
          using 3 4 by auto
      qed
    qed

    have "?U0 = ?A"
    proof
      show "?U0 ⊆ ?A" by fact
    next
      show "?A ⊆ ?U0"
        using  ‹?U1 ⊆ ?B› Compl_subset_Compl_iff[of ?U0 ?A] hi1 hiu1
        by blast
    qed

    have "?U1 = ?B"
      using ‹?U0 = ?A› hi1 hiu1 by auto
    show ?thesis
      using ‹?U0 = ?A› ‹?U1 = ?B› ‹?A ∈ sets borel› ‹?B ∈ sets borel›
      by simp
  qed
  thus ?thesis
    using f01_borel_measurable[of "(λr. real (r01_binary_expansion' r n))"] real01_binary_expansion'_0or1[of _ n]
    by simp
qed



(* (0,1) ⇒ [0,1]×[0,1]. *)
definition r01_to_r01_r01_fst' :: "real ⇒ nat ⇒ nat" where
"r01_to_r01_r01_fst' r n ≡ r01_binary_expansion' r (2*n)"

lemma r01_to_r01_r01_fst'in01:
  "⋀n. r01_to_r01_r01_fst' r n ∈ {0,1}"
  using real01_binary_expansion'_0or1 by (simp add: r01_to_r01_r01_fst'_def)

definition r01_to_r01_r01_fst_sum :: "real ⇒ nat ⇒ real" where
"r01_to_r01_r01_fst_sum ≡ r01_binary_sum ∘ r01_to_r01_r01_fst'"

definition r01_to_r01_r01_fst :: "real ⇒ real" where
"r01_to_r01_r01_fst = lim ∘ r01_to_r01_r01_fst_sum"

lemma r01_to_r01_r01_fst_def':
  "r01_to_r01_r01_fst r = (∑n. real (r01_binary_expansion' r (2*n)) * (1/2)^(n+1))"
proof -
  have "r01_to_r01_r01_fst_sum r = (λn. ∑i=0..n. real (r01_binary_expansion' r (2*i)) * (1/2)^(i+1))"
    by(auto simp add: r01_to_r01_r01_fst_sum_def r01_binary_sum_def r01_to_r01_r01_fst'_def)
  thus ?thesis
    using lim_sum_ai real01_binary_expansion'_0or1
    by(simp add: r01_to_r01_r01_fst_def)
qed

lemma r01_to_r01_r01_fst_measurable:
 "r01_to_r01_r01_fst ∈ borel_measurable borel"
  unfolding r01_to_r01_r01_fst_def'
  using r01_binary_expansion'_measurable by auto


definition r01_to_r01_r01_snd' :: "real ⇒ nat ⇒ nat" where
"r01_to_r01_r01_snd' r n = r01_binary_expansion' r (2*n + 1)"

lemma r01_to_r01_r01_snd'in01:
  "⋀n. r01_to_r01_r01_snd' r n ∈ {0,1}"
  using real01_binary_expansion'_0or1 by (simp add: r01_to_r01_r01_snd'_def)


definition r01_to_r01_r01_snd_sum :: "real ⇒ nat ⇒ real" where
"r01_to_r01_r01_snd_sum ≡ r01_binary_sum ∘ r01_to_r01_r01_snd'"

definition r01_to_r01_r01_snd :: "real ⇒ real" where
"r01_to_r01_r01_snd = lim ∘ r01_to_r01_r01_snd_sum"

lemma r01_to_r01_r01_snd_def':
  "r01_to_r01_r01_snd r = (∑n. real (r01_binary_expansion' r (2*n + 1)) * (1/2)^(n+1))"
proof -
  have "r01_to_r01_r01_snd_sum r = (λn. ∑i=0..n. real (r01_binary_expansion' r (2*i + 1)) * (1/2)^(i+1))"
    by(auto simp add: r01_to_r01_r01_snd_sum_def r01_binary_sum_def r01_to_r01_r01_snd'_def)
  thus ?thesis
    using lim_sum_ai real01_binary_expansion'_0or1
    by(simp add: r01_to_r01_r01_snd_def)
qed

lemma r01_to_r01_r01_snd_measurable:
 "r01_to_r01_r01_snd ∈ borel_measurable borel"
  unfolding r01_to_r01_r01_snd_def'
  using r01_binary_expansion'_measurable by auto


definition r01_to_r01_r01 :: "real ⇒ real × real" where
"r01_to_r01_r01 r = (r01_to_r01_r01_fst r,r01_to_r01_r01_snd r)"

lemma r01_to_r01_r01_image:
 "r01_to_r01_r01 r ∈ {0..1}×{0..1}"
  using r01_to_r01_r01_fst_def'[of r] r01_to_r01_r01_snd_def'[of r] real01_binary_expansion'_0or1
        binary_expression_gteq0[of "λn. r01_binary_expansion' r (2*n)" 0] binary_expression_leeq1[of "λn. r01_binary_expansion' r (2*n)" 0] binary_expression_gteq0[of "λn. r01_binary_expansion' r (2*n+1)" 0] binary_expression_leeq1[of "λn. r01_binary_expansion' r (2*n+1)" 0]
  by(simp add: r01_to_r01_r01_def)

lemma r01_to_r01_r01_measurable:
 "r01_to_r01_r01 ∈ real_borel →M real_borel ⨂M real_borel"
  unfolding r01_to_r01_r01_def
  using borel_measurable_Pair[of r01_to_r01_r01_fst borel r01_to_r01_r01_snd] r01_to_r01_r01_fst_measurable r01_to_r01_r01_snd_measurable
  by(simp add: borel_prod)

lemma r01_to_r01_r01_3over4:
 "r01_to_r01_r01 (3/4) = (1/2,1/2)"
proof -
  have h0:"r01_binary_expansion' (3/4) 0 = 1"
    by (simp add: r01_binary_expansion'_def)
  have h1:"r01_binary_expansion' (3/4) 1 = 1"
    by (simp add: r01_binary_expansion'_def Let_def of_rat_divide)
  have hn:"⋀n. n>1⟹ r01_binary_expansion' (3/4) n = 0"
  proof -
    fix n :: nat
    assume h:"1 < n"
    show "r01_binary_expansion' (3 / 4) n = 0"
    proof(rule ccontr)
      assume "r01_binary_expansion' (3 / 4) n ≠ 0"
      have "3/4 < (∑i=0..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i))"
      proof -
        have "(∑i=0..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i)) = real (r01_binary_expansion' (3/4) 0) * (1/2)^(Suc 0) + (∑i=(Suc 0)..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i))"
          by(rule sum.atLeast_Suc_atMost) (simp add: h)
        also have "... = real (r01_binary_expansion' (3/4) 0) * (1/2)^(Suc 0) + (real (r01_binary_expansion' (3/4) 1) * (1/2)^(Suc 1) + (∑i=(Suc (Suc 0))..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i)))"
          using sum.atLeast_Suc_atMost[OF order.strict_implies_order[OF h],of "λi. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i)"]
          by simp
        also have "... = 3/4 + (∑i=2..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i))"
          using h0 h1 by(simp add: numeral_2_eq_2)
        also have "... > 3/4"
        proof -
          have "(∑i=2..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i)) = (∑i=2..n-1. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i)) + real (r01_binary_expansion' (3/4) n) * (1/2)^Suc n"
            by (metis (no_types, lifting) h One_nat_def Suc_pred less_2_cases_iff less_imp_add_positive order_less_irrefl plus_1_eq_Suc sum.cl_ivl_Suc zero_less_Suc)
          hence "real (r01_binary_expansion' (3/4) n) * (1/2)^Suc n ≤ (∑i=2..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i))"
            using ordered_comm_monoid_add_class.sum_nonneg[of "{2..n-1}" "λi. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i)"]
            by simp
          moreover have "0 < real (r01_binary_expansion' (3/4) n) * (1/2)^Suc n"
            using ‹r01_binary_expansion' (3 / 4) n ≠ 0› by simp
          ultimately have "0 < (∑i=2..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i))"
            by simp
          thus ?thesis by simp
        qed
        finally show "3 / 4 < (∑i = 0..n. real (r01_binary_expansion' (3 / 4) i) * (1 / 2) ^ Suc i)" .
      qed
      moreover have "(∑i=0..n. real (r01_binary_expansion' (3/4) i) * (1/2)^(Suc i)) ≤ 3/4"
        using r01_binary_expansion_lr_r_ur[of "3/4" n] r01_binary_expression_eq_lr[of "3/4" n]
        by(simp add: r01_binary_expression_def r01_binary_sum_def)
      ultimately show False by simp
    qed
  qed
  show ?thesis
  proof
    have "fst (r01_to_r01_r01 (3 / 4)) = (∑n. real (r01_binary_expansion' (3 / 4) (2 * n)) * (1 / 2) ^ Suc n)"
      by(simp add: r01_to_r01_r01_def r01_to_r01_r01_fst_def')
    also have "... = 1/2 + (∑n. real (r01_binary_expansion' (3 / 4) (2 * Suc n)) * (1 / 2) ^ Suc (Suc n))"
      using suminf_split_head[of "λn. real (r01_binary_expansion' (3 / 4) (2 * n)) * (1 / 2) ^ Suc n"] binary_expression_summable[of "λn. r01_binary_expansion' (3/4) (2*n)"] real01_binary_expansion'_0or1[of "3/4"] h0
      by simp
    also have "... = 1/2"
    proof -
      have "∀n. real (r01_binary_expansion' (3 / 4) (2 * Suc n)) * (1 / 2) ^ Suc (Suc n) = 0"
        using hn by simp
      hence "(∑n. real (r01_binary_expansion' (3 / 4) (2 * Suc n)) * (1 / 2) ^ Suc (Suc n)) = 0"
        by simp
      thus ?thesis
        by simp
    qed
    finally show "fst (r01_to_r01_r01 (3 / 4)) = fst (1 / 2, 1 / 2)"
      by simp
  next
    have "snd (r01_to_r01_r01 (3 / 4)) = (∑n. real (r01_binary_expansion' (3 / 4) (2 * n + 1)) * (1 / 2) ^ Suc n)"
      by(simp add: r01_to_r01_r01_def r01_to_r01_r01_snd_def')
    also have "... = 1/2 + (∑n. real (r01_binary_expansion' (3 / 4) (2 * Suc n + 1)) * (1 / 2) ^ Suc (Suc n))"
      using suminf_split_head[of "λn. real (r01_binary_expansion' (3 / 4) (2 * n + 1)) * (1 / 2) ^ Suc n"] binary_expression_summable[of "λn. r01_binary_expansion' (3/4) (2*n + 1)"] real01_binary_expansion'_0or1[of "3/4"] h1
      by simp
    also have "... = 1/2"
    proof -
      have "∀n. real (r01_binary_expansion' (3 / 4) (2 * Suc n + 1)) * (1 / 2) ^ Suc (Suc n) = 0"
        using hn by simp
      hence "(∑n. real (r01_binary_expansion' (3 / 4) (2 * Suc n + 1)) * (1 / 2) ^ Suc (Suc n)) = 0"
        by simp
      thus ?thesis
        by simp
    qed
    finally show "snd (r01_to_r01_r01 (3 / 4)) = snd (1 / 2, 1 / 2)"
      by simp
  qed
qed


(* (0,1)×(0,1) ⇒ (0,1). *)
definition r01_r01_to_r01' :: "real × real ⇒ nat ⇒ nat" where
"r01_r01_to_r01' rs ≡ (λn. if even n then r01_binary_expansion' (fst rs) (n div 2)
                                      else r01_binary_expansion' (snd rs) ((n-1) div 2))"

lemma r01_r01_to_r01'in01:
  "⋀n. r01_r01_to_r01' rs n ∈ {0,1}"
  using real01_binary_expansion'_0or1 by (simp add: r01_r01_to_r01'_def)

lemma r01_r01_to_r01'_well_formed:
  assumes "0 < r1" "r1 < 1"
      and "0 < r2" "r2 < 1"
    shows "biexp01_well_formed (r01_r01_to_r01' (r1,r2))"
  using biexp01_well_formed_comb[of "r01_binary_expansion' (fst (r1,r2))" "r01_binary_expansion' (snd (r1,r2))"] r01_binary_expansion_well_formed[of r1] r01_binary_expansion_well_formed[of r2] assms
  by (auto simp add: r01_r01_to_r01'_def)

definition r01_r01_to_r01_sum :: "real × real ⇒ nat ⇒ real" where
"r01_r01_to_r01_sum ≡ r01_binary_sum ∘ r01_r01_to_r01'"

definition r01_r01_to_r01 :: "real × real ⇒ real" where
"r01_r01_to_r01 ≡ lim ∘ r01_r01_to_r01_sum"

lemma r01_r01_to_r01_def':
 "r01_r01_to_r01 (r1,r2) = (∑n. real (r01_r01_to_r01' (r1,r2) n) * (1/2)^(n+1))"
proof -
  have "r01_r01_to_r01_sum (r1,r2) = (λn. (∑i = 0..n. real (r01_r01_to_r01' (r1,r2) i) * (1 / 2) ^ Suc i))"
    by(auto simp add: r01_r01_to_r01_sum_def r01_binary_sum_def)
  thus ?thesis
    using lim_sum_ai[of "λn. r01_r01_to_r01' (r1,r2) n"] r01_r01_to_r01'in01
    by(simp add: r01_r01_to_r01_def)
qed

lemma r01_r01_to_r01_measurable:
 "r01_r01_to_r01 ∈ real_borel ⨂M real_borel →M real_borel"
proof -
  have "r01_r01_to_r01 = (λx. ∑n. real (r01_r01_to_r01' x n) * (1/2)^(n+1))"
    using r01_r01_to_r01_def' by auto
  also have "... ∈ real_borel ⨂M real_borel →M real_borel"
  proof(rule borel_measurable_suminf)
    fix n :: nat
    have "(λx. real (r01_r01_to_r01' x n) * (1 / 2) ^ (n + 1)) = (λr. r * (1/2)^(n+1)) ∘ (λx. real (r01_r01_to_r01' x n))"
      by auto
    also have "... ∈ borel_measurable (borel ⨂M borel)"
    proof(rule measurable_comp[of _ _ borel])
      have "(λx. real (r01_r01_to_r01' x n))
           = (λx. if even n then real (r01_binary_expansion' (fst x) (n div 2)) else real (r01_binary_expansion' (snd x) ((n - 1) div 2)))"
        by (auto simp add: r01_r01_to_r01'_def)
      also have "... ∈  borel_measurable (borel ⨂M borel)"
        using r01_binary_expansion'_measurable by simp
      finally show "(λx. real (r01_r01_to_r01' x n)) ∈ borel_measurable (borel ⨂M borel)" .
    next
      show "(λr::real. r * (1 / 2) ^ (n + 1)) ∈ borel_measurable borel"
        by simp
    qed
    finally show "(λx. real (r01_r01_to_r01' x n) * (1 / 2) ^ (n + 1)) ∈ borel_measurable (borel ⨂M borel)" .
  qed
  finally show ?thesis .
qed

lemma r01_r01_to_r01_image:
  assumes "0 < r1" "r1 < 1"
    shows "r01_r01_to_r01 (r1,r2) ∈ {0<..<1}"
proof -
  obtain i where "r01_binary_expansion' r1 i = 1"
    using r01_binary_expression_ex1[of r1] assms(1,2)
    by auto
  hence hi:"r01_r01_to_r01' (r1,r2) (2*i) = 1"
    by(simp add: r01_r01_to_r01'_def)
  obtain j where "r01_binary_expansion' r1 j = 0"
    using r01_binary_expression_ex0[of r1] assms(1,2)
    by auto
  hence hj:"r01_r01_to_r01' (r1,r2) (2*j) = 0"
    by(simp add: r01_r01_to_r01'_def)
  show ?thesis
    using ai_exists1_gt0[of "r01_r01_to_r01' (r1,r2)"] ai_exists0_less_than1[of "r01_r01_to_r01' (r1,r2)"] r01_r01_to_r01'in01[of "(r1,r2)"] r01_r01_to_r01_def'[of r1 r2] hi hj
    by auto
qed

lemma r01_r01_to_r01_image':
  assumes "0 < r2" "r2 < 1"
    shows "r01_r01_to_r01 (r1,r2) ∈ {0<..<1}"
proof -
  obtain i where "r01_binary_expansion' r2 i = 1"
    using r01_binary_expression_ex1[of r2] assms(1,2)
    by auto
  hence hi:"r01_r01_to_r01' (r1,r2) (2*i + 1) = 1"
    by(simp add: r01_r01_to_r01'_def)
  obtain j where "r01_binary_expansion' r2 j = 0"
    using r01_binary_expression_ex0[of r2] assms(1,2)
    by auto
  hence hj:"r01_r01_to_r01' (r1,r2) (2*j + 1) = 0"
    by(simp add: r01_r01_to_r01'_def)
  show ?thesis
    using ai_exists1_gt0[of "r01_r01_to_r01' (r1,r2)"] ai_exists0_less_than1[of "r01_r01_to_r01' (r1,r2)"] r01_r01_to_r01'in01[of "(r1,r2)"] r01_r01_to_r01_def'[of r1 r2] hi hj
    by auto
qed


lemma r01_r01_to_r01_binary_nth:
  assumes "0 < r1" "r1 < 1"
      and "0 < r2" "r2 < 1"
    shows "r01_binary_expansion' r1 n = r01_binary_expansion' (r01_r01_to_r01 (r1,r2)) (2*n) ∧
           r01_binary_expansion' r2 n = r01_binary_expansion' (r01_r01_to_r01 (r1,r2)) (2*n + 1)"
proof -
  have "⋀n. r01_binary_expansion' (r01_r01_to_r01 (r1,r2)) n = r01_r01_to_r01' (r1,r2) n"
    using r01_r01_to_r01_def'[of r1 r2] biexp01_well_formed_an[of "r01_r01_to_r01' (r1,r2)"] r01_r01_to_r01'_well_formed[of r1 r2] assms
    by simp
  thus ?thesis
    by(simp add: r01_r01_to_r01'_def)
qed

lemma r01_r01__r01__r01_r01_id:
  assumes "0 < r1" "r1 < 1"
          "0 < r2" "r2 < 1"
    shows "(r01_to_r01_r01 ∘ r01_r01_to_r01) (r1,r2) = (r1,r2)"
proof
  show "fst ((r01_to_r01_r01 ∘ r01_r01_to_r01) (r1, r2)) = fst (r1, r2)"
  proof -
    have "fst ((r01_to_r01_r01 ∘ r01_r01_to_r01) (r1, r2)) = r01_to_r01_r01_fst (r01_r01_to_r01 (r1,r2))"
      by(simp add: r01_to_r01_r01_def)
    also have "... = (∑n. real (r01_binary_expansion' (r01_r01_to_r01 (r1, r2)) (2 * n)) * (1 / 2) ^ (n + 1))"
      using r01_to_r01_r01_fst_def'[of "r01_r01_to_r01 (r1,r2)"] by simp
    also have "... = (∑n. real (r01_binary_expansion' r1 n) * (1 / 2) ^ (n + 1))"
      using r01_r01_to_r01_binary_nth[of r1 r2] assms by simp
    also have "... = r1"
      using r01_binary_expression_correct[of r1] assms(1,2)
      by simp
    finally show ?thesis by simp
  qed
next
  show "snd ((r01_to_r01_r01 ∘ r01_r01_to_r01) (r1, r2)) = snd (r1, r2)"
  proof -
    have "snd ((r01_to_r01_r01 ∘ r01_r01_to_r01) (r1, r2)) = r01_to_r01_r01_snd (r01_r01_to_r01 (r1,r2))"
      by(simp add: r01_to_r01_r01_def)
    also have "... = (∑n. real (r01_binary_expansion' (r01_r01_to_r01 (r1, r2)) (2 * n + 1)) * (1 / 2) ^ (n + 1))"
      using r01_to_r01_r01_snd_def'[of "r01_r01_to_r01 (r1,r2)"] by simp
    also have "... = (∑n. real (r01_binary_expansion' r2 n) * (1 / 2) ^ (n + 1))"
      using r01_r01_to_r01_binary_nth[of r1 r2] assms by simp
    also have "... = r2"
      using r01_binary_expression_correct[of r2] assms(3,4)
      by simp
    finally show ?thesis by simp
  qed
qed

text ‹ We first show that ‹M ⨂M N› is a standard Borel space for standard Borel spaces ‹M› and ‹N›.›
lemma pair_measurable[measurable]:
  assumes "f ∈ X →M Y"
      and "g ∈ X' →M Y'"
    shows "map_prod f g ∈ X ⨂M X' →M Y ⨂M Y'"
  using assms by(auto simp add: measurable_pair_iff)

lemma pair_standard_borel_standard:
  assumes "standard_borel M"
      and "standard_borel N"
    shows "standard_borel (M ⨂M N)"
proof -
  ― ‹ First, define the measurable function $\mathbb{R} \times \mathbb{R} \rightarrow \mathbb{R}$.›
  define rr_to_r :: "real × real ⇒ real"
    where "rr_to_r ≡ real_to_01open_inverse ∘ r01_r01_to_r01 ∘ (λ(x,y). (real_to_01open x, real_to_01open y))"
  ― ‹ $\mathbb{R}\times\mathbb{R} \rightarrow (0,1)\times(0,1) \rightarrow (0,1) \rightarrow \mathbb{R}$.›
  have 1[measurable]: "rr_to_r ∈ real_borel ⨂M real_borel →M real_borel"
  proof -
    have "(λ(x,y). (real_to_01open x, real_to_01open y)) ∈ real_borel ⨂M real_borel →M real_borel ⨂M real_borel"
      using borel_measurable_continuous_onI[OF real_to_01open_continuous]
      by simp
    from measurable_restrict_space2[OF _ this,of "{0<..<1}×{0<..<1}"]
    have [measurable]:"(λ(x,y). (real_to_01open x, real_to_01open y)) ∈ real_borel ⨂M real_borel →M restrict_space (real_borel ⨂M real_borel) ({0<..<1}×{0<..<1})"
      by(simp add: split_beta' real_to_01open_01)
    have [measurable]: "r01_r01_to_r01 ∈ restrict_space (real_borel ⨂M real_borel) ({0<..<1}×{0<..<1}) →M restrict_space real_borel {0<..<1}"
      using r01_r01_to_r01_image' by(auto intro!: measurable_restrict_space3[OF r01_r01_to_r01_measurable])
    thus ?thesis
      using borel_measurable_continuous_on_restrict[OF real_to_01open_inverse_continuous]
      by(simp add: rr_to_r_def)
  qed
  ― ‹ Next, define the measurable function $\mathbb{R}\rightarrow \mathbb{R}\times\mathbb{R}$.›
  define r_to_01 :: "real ⇒ real"
    where "r_to_01 ≡ (λr. if r ∈ real_to_01open -` (r01_to_r01_r01 -` ({0<..<1}×{0<..<1})) then real_to_01open r else 3/4)"
  define r01_to_r01_r01' :: "real ⇒ real × real"
    where "r01_to_r01_r01' ≡ (λr. if r ∈ r01_to_r01_r01 -` ({0<..<1}×{0<..<1}) then r01_to_r01_r01 r else (1/2,1/2))"
  define r_to_rr :: "real ⇒ real × real"
    where "r_to_rr ≡ (λ(x,y). (real_to_01open_inverse x, real_to_01open_inverse y)) ∘ r01_to_r01_r01' ∘ r_to_01"
  ― ‹ $\mathbb{R} \rightarrow (0,1) \rightarrow (0,1)\times(0,1) \rightarrow \mathbb{R}\times\mathbb{R}$.›
  have 2[measurable]: "r_to_rr ∈ real_borel →M real_borel ⨂M real_borel"
  proof -
    have 1: "{0<..<1}×{0<..<1} ∈ sets (restrict_space (real_borel ⨂M real_borel) ({0..1}×{0..1}))"
      by(auto simp: sets_restrict_space_iff)
    have 2[measurable]: "real_to_01open ∈ real_borel →M restrict_space real_borel {0<..<1}"
      using measurable_restrict_space2[OF _ borel_measurable_continuous_onI[OF real_to_01open_continuous] ,of "{0<..<1}"]
      by(simp add: real_to_01open_01)
    have 3: "real_to_01open -` space (restrict_space real_borel {0<..<1}) = UNIV"
      using real_to_01open_01 by auto
    have "r01_to_r01_r01 ∈ restrict_space real_borel {0<..<1} →M restrict_space (real_borel ⨂M real_borel) ({0..1}×{0..1})"
      using r01_to_r01_r01_image measurable_restrict_space3[OF r01_to_r01_r01_measurable] by simp
    note 4 = measurable_sets[OF this 1]
    note 5 = measurable_sets[OF 2 4,simplified vimage_Int 3,simplified]
    have [measurable]:"r_to_01 ∈ real_borel →M restrict_space real_borel {0<..<1}"
      unfolding r_to_01_def
      by(rule  measurable_If_set) (auto intro!: measurable_restrict_space2 simp: 5)
    have [measurable]: "r01_to_r01_r01' ∈ restrict_space real_borel {0<..<1} →M restrict_space (real_borel ⨂M real_borel) ({0<..<1}×{0<..<1})"
      using 4 r01_to_r01_r01_measurable
      by(auto intro!: measurable_restrict_space3 simp: r01_to_r01_r01'_def)
    have [measurable]: "(λ(x,y). (real_to_01open_inverse x, real_to_01open_inverse y)) ∈ restrict_space (real_borel ⨂M real_borel) ({0<..<1}×{0<..<1}) →M real_borel ⨂M real_borel"
      using borel_measurable_continuous_on_restrict[OF continuous_on_Pair[OF continuous_on_compose[of "{0<..<1::real}×{0<..<1::real}",OF continuous_on_fst[OF continuous_on_id'],simplified,OF real_to_01open_inverse_continuous] continuous_on_compose[of "{0<..<1::real}×{0<..<1::real}",OF continuous_on_snd[OF continuous_on_id'],simplified,OF real_to_01open_inverse_continuous]]]
      by(simp add: split_beta' borel_prod)
    show ?thesis
      by(simp add: r_to_rr_def)
  qed
  have 3: "⋀x. r_to_rr (rr_to_r x) = x"
    using r01_to_r01_r01_image r01_r01_to_r01_image r01_r01__r01__r01_r01_id real_to_01open_01  real_to_01open_inverse_correct' fun_cong[OF real_to_01open_inverse_correct]
    by(auto simp add: r01_to_r01_r01'_def r_to_01_def comp_def split_beta' r_to_rr_def rr_to_r_def)

  interpret s1: standard_borel M by fact
  interpret s2: standard_borel N by fact
  show ?thesis
    by(auto intro!: standard_borelI[where f="rr_to_r ∘ map_prod s1.f s2.f" and g="map_prod s1.g s2.g ∘ r_to_rr"] simp: 3 space_pair_measure)
qed

lemma pair_standard_borel_spaceUNIV:
  assumes "standard_borel_space_UNIV M"
      and "standard_borel_space_UNIV N"
    shows "standard_borel_space_UNIV (M ⨂M N)"
  apply(rule standard_borel_space_UNIVI')
  using assms pair_standard_borel_standard[of M N]
  by(auto simp add: standard_borel_space_UNIV_def standard_borel_space_UNIV_axioms_def space_pair_measure)


locale pair_standard_borel = s1: standard_borel M + s2: standard_borel N
  for M :: "'a measure" and N :: "'b measure"
begin

sublocale standard_borel "M ⨂M N"
  by(auto intro!: pair_standard_borel_standard)

end

locale pair_standard_borel_space_UNIV = s1: standard_borel_space_UNIV M + s2: standard_borel_space_UNIV N
  for M :: "'a measure" and N :: "'b measure"
begin

sublocale pair_standard_borel M N
  by standard

sublocale standard_borel_space_UNIV "M ⨂M N"
  by(auto intro!: pair_standard_borel_spaceUNIV
      simp: s1.standard_borel_space_UNIV_axioms s2.standard_borel_space_UNIV_axioms)

end


text ‹$\mathbb{R}\times\mathbb{R}$ is a standard Borel space.›
interpretation real_real : pair_standard_borel_space_UNIV real_borel real_borel
  by(auto intro!: pair_standard_borel_spaceUNIV simp: real.standard_borel_space_UNIV_axioms pair_standard_borel_space_UNIV_def)

subsection ‹ $\mathbb{N}\times\mathbb{R}$ ›
text ‹ $\mathbb{N}\times\mathbb{R}$ is a standard Borel space. ›
interpretation nat_real: pair_standard_borel_space_UNIV nat_borel real_borel
  by(auto intro!: pair_standard_borel_spaceUNIV
       simp: real.standard_borel_space_UNIV_axioms nat.standard_borel_space_UNIV_axioms pair_standard_borel_space_UNIV_def)

end
>

Theory QuasiBorel

(*  Title:   QuasiBorel.thy
    Author:  Yasuhiko Minamide, Michikazu Hirata, Tokyo Institute of Technology
*)

section ‹Quasi-Borel Spaces›
theory QuasiBorel
imports "StandardBorel"
begin

subsection ‹ Definitions ›

text ‹ We formalize quasi-Borel spaces introduced by Heunen et al.~\cite{Heunen_2017}.›

subsubsection ‹ Quasi-Borel Spaces›
definition qbs_closed1 :: "(real ⇒ 'a) set ⇒ bool"
  where "qbs_closed1 Mx ≡ (∀a ∈ Mx. ∀f ∈ real_borel →M real_borel. a ∘ f ∈ Mx)"

definition qbs_closed2 :: "['a set, (real ⇒ 'a) set] ⇒ bool"
 where "qbs_closed2 X Mx ≡ (∀x ∈ X. (λr. x) ∈ Mx)"

definition qbs_closed3 :: "(real ⇒ 'a) set ⇒ bool"
 where "qbs_closed3 Mx ≡ (∀P::real ⇒ nat. ∀Fi::nat ⇒ real ⇒ 'a.
                          (∀i. P -` {i} ∈ sets real_borel)
                           ⟶ (∀i. Fi i ∈ Mx)
                           ⟶ (λr. Fi (P r) r) ∈ Mx)"

lemma separate_measurable:
  fixes P :: "real ⇒ nat"
  assumes "⋀i. P -` {i} ∈ sets real_borel"
  shows "P ∈ real_borel →M nat_borel"
proof -
  have "P ∈ real_borel →M count_space UNIV"
    by (auto simp add: assms measurable_count_space_eq_countable)
  thus ?thesis
    using measurable_cong_sets sets_borel_eq_count_space by blast
qed

lemma measurable_separate:
  fixes P :: "real ⇒ nat"
  assumes "P ∈ real_borel →M nat_borel"
  shows "P -` {i} ∈ sets real_borel"
  by(rule measurable_sets_borel[OF assms borel_singleton[OF sets.empty_sets,of i]])

definition "is_quasi_borel X Mx ⟷ Mx ⊆ UNIV → X ∧ qbs_closed1 Mx ∧ qbs_closed2 X Mx ∧ qbs_closed3 Mx"

lemma is_quasi_borel_intro[simp]:
  assumes "Mx ⊆ UNIV → X"
      and "qbs_closed1 Mx" "qbs_closed2 X Mx" "qbs_closed3 Mx"
    shows "is_quasi_borel X Mx"
  using assms by(simp add: is_quasi_borel_def)

typedef 'a quasi_borel = "{(X::'a set, Mx). is_quasi_borel X Mx}"
proof
  show "(UNIV, UNIV) ∈ {(X::'a set, Mx). is_quasi_borel X Mx}"
    by (simp add: is_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def)
qed

definition qbs_space :: "'a quasi_borel ⇒ 'a set" where
  "qbs_space X ≡ fst (Rep_quasi_borel X)"

definition qbs_Mx :: "'a quasi_borel ⇒ (real ⇒ 'a) set" where
  "qbs_Mx X ≡ snd (Rep_quasi_borel X)"

lemma qbs_decomp : 
"(qbs_space X,qbs_Mx X) ∈ {(X::'a set, Mx). is_quasi_borel X Mx}"
  by (simp add: qbs_space_def qbs_Mx_def Rep_quasi_borel[simplified])

lemma qbs_Mx_to_X[dest]:
  assumes "α ∈ qbs_Mx X"
  shows "α ∈ UNIV → qbs_space X"
        "α r ∈ qbs_space X"
  using qbs_decomp assms by(auto simp: is_quasi_borel_def)


lemma qbs_closed1I:
  assumes "⋀α f. α ∈ Mx ⟹ f ∈ real_borel →M real_borel ⟹ α ∘ f ∈ Mx"
  shows "qbs_closed1 Mx"
  using assms by(simp add: qbs_closed1_def)

lemma qbs_closed1_dest[simp]:
  assumes "α ∈ qbs_Mx X"
      and "f ∈ real_borel →M real_borel"
    shows "α ∘ f ∈ qbs_Mx X"
  using assms qbs_decomp by (auto simp add: is_quasi_borel_def qbs_closed1_def)

lemma qbs_closed2I:
  assumes "⋀x. x ∈ X ⟹ (λr. x) ∈ Mx"
  shows "qbs_closed2 X Mx"
  using assms by(simp add: qbs_closed2_def)

lemma qbs_closed2_dest[simp]:
  assumes "x ∈ qbs_space X"
  shows "(λr. x) ∈ qbs_Mx X"
  using assms qbs_decomp[of X] by (auto simp add: is_quasi_borel_def qbs_closed2_def)

lemma qbs_closed3I:
  assumes "⋀(P :: real ⇒ nat) Fi. (⋀i. P -` {i} ∈ sets real_borel) ⟹ (⋀i. Fi i ∈ Mx)
                  ⟹ (λr. Fi (P r) r) ∈ Mx"
  shows "qbs_closed3 Mx"
  using assms by(auto simp: qbs_closed3_def)

lemma qbs_closed3I':
  assumes "⋀(P :: real ⇒ nat) Fi. P ∈ real_borel →M nat_borel ⟹ (⋀i. Fi i ∈ Mx)
                  ⟹ (λr. Fi (P r) r) ∈ Mx"
  shows "qbs_closed3 Mx"
  using assms by(auto intro!: qbs_closed3I simp: separate_measurable)

lemma qbs_closed3_dest[simp]:
  fixes P::"real ⇒ nat" and Fi :: "nat ⇒ real ⇒ _"
  assumes "⋀i. P -` {i} ∈ sets real_borel"
      and "⋀i. Fi i ∈ qbs_Mx X"
    shows "(λr. Fi (P r) r) ∈ qbs_Mx X"
  using assms qbs_decomp[of X] by (auto simp add: is_quasi_borel_def qbs_closed3_def)

lemma qbs_closed3_dest':
  fixes P::"real ⇒ nat" and Fi :: "nat ⇒ real ⇒ _"
  assumes "P ∈ real_borel →M nat_borel"
      and "⋀i. Fi i ∈ qbs_Mx X"
    shows "(λr. Fi (P r) r) ∈ qbs_Mx X"
  using qbs_closed3_dest[OF measurable_separate[OF assms(1)] assms(2)] .

lemma qbs_closed3_dest2:
  assumes "countable I"
 and [measurable]: "P ∈ real_borel →M count_space I"
      and "⋀i. i ∈ I ⟹ Fi i ∈ qbs_Mx X"
    shows "(λr. Fi (P r) r) ∈ qbs_Mx X"
proof -
  have 0:"I ≠ {}"
    using measurable_empty_iff[of "count_space I" P real_borel] assms(2)
    by fastforce
  define P' where "P' ≡ to_nat_on I ∘ P"
  define Fi' where "Fi' ≡ Fi ∘ (from_nat_into I)"
  have 1:"P' ∈ real_borel →M nat_borel"
    by(simp add: P'_def)
  have 2:"⋀i. Fi' i ∈ qbs_Mx X"
    using assms(3) from_nat_into[OF 0] by(simp add: Fi'_def)
  have "(λr. Fi' (P' r) r) ∈ qbs_Mx X"
    using 1 2 measurable_separate by auto
  thus ?thesis
    using from_nat_into_to_nat_on[OF assms(1)] measurable_space[OF assms(2)]
    by(auto simp: Fi'_def P'_def)
qed

lemma qbs_closed3_dest2':
  assumes "countable I"
 and [measurable]: "P ∈ real_borel →M count_space I"
      and "⋀i. i ∈ range P ⟹ Fi i ∈ qbs_Mx X"
    shows "(λr. Fi (P r) r) ∈ qbs_Mx X"
proof -
  have 0:"range P ∩ I = range P"
    using measurable_space[OF assms(2)] by auto
  have 1:"P ∈ real_borel →M count_space (range P)"
    using restrict_count_space[of I "range P"] measurable_restrict_space2[OF _ assms(2),of "range P"]
    by(simp add: 0)
  have 2:"countable (range P)"
    using countable_Int2[OF assms(1),of "range P"]
    by(simp add: 0)
  show ?thesis
    by(auto intro!: qbs_closed3_dest2[OF 2 1 assms(3)])
qed

lemma qbs_space_Mx:
 "qbs_space X = {α x |x α. α ∈ qbs_Mx X}"
proof auto
  fix x
  assume 1:"x ∈ qbs_space X"
  show "∃xa α. x = α xa ∧ α ∈ qbs_Mx X"
    by(auto intro!: exI[where x=0] exI[where x="(λr. x)"] simp: 1)
qed

lemma qbs_space_eq_Mx:
  assumes "qbs_Mx X = qbs_Mx Y"
  shows "qbs_space X = qbs_space Y"
  by(simp add: qbs_space_Mx assms)

lemma qbs_eqI:
  assumes "qbs_Mx X = qbs_Mx Y"
  shows "X = Y"
  by (metis Rep_quasi_borel_inverse prod.exhaust_sel qbs_Mx_def qbs_space_def assms qbs_space_eq_Mx[OF assms])


subsubsection ‹ Morphism of Quasi-Borel Spaces ›
definition qbs_morphism :: "['a quasi_borel, 'b quasi_borel] ⇒ ('a ⇒ 'b) set" (infixr "→Q" 60) where 
  "X →Q Y ≡ {f ∈ qbs_space X → qbs_space Y. ∀α ∈ qbs_Mx X. f ∘ α ∈ qbs_Mx Y}"

lemma qbs_morphismI:
  assumes "⋀α. α ∈ qbs_Mx X ⟹ f ∘ α ∈ qbs_Mx Y"
  shows "f ∈ X →Q Y"
proof -
  have "f ∈ qbs_space X → qbs_space Y"
  proof
    fix x
    assume "x ∈ qbs_space X "
    then have "(λr. x) ∈ qbs_Mx X"
      by simp
    hence "f ∘ (λr. x) ∈ qbs_Mx Y"
      using assms by blast
    thus "f x ∈ qbs_space Y"
      by auto
  qed
  thus ?thesis
    using assms by(simp add: qbs_morphism_def)
qed

lemma qbs_morphismE[dest]:
  assumes "f ∈ X →Q Y"
  shows "f ∈ qbs_space X → qbs_space Y"
        "⋀x. x ∈ qbs_space X ⟹ f x ∈ qbs_space Y"
        "⋀α. α ∈ qbs_Mx X ⟹ f ∘ α ∈ qbs_Mx Y"
  using assms by(auto simp add: qbs_morphism_def)

lemma qbs_morphism_ident[simp]:
   "id ∈ X →Q X"
  by(auto intro: qbs_morphismI)

lemma qbs_morphism_ident'[simp]:
   "(λx. x) ∈ X →Q X"
  using qbs_morphism_ident by(simp add: id_def)


lemma qbs_morphism_comp:
  assumes "f ∈ X →Q Y" "g ∈ Y →Q Z"
  shows "g ∘ f ∈ X →Q Z"
  using assms by (simp add: comp_assoc Pi_def qbs_morphism_def)

lemma qbs_morphism_cong:
  assumes "⋀x. x ∈ qbs_space X ⟹ f x = g x"
      and "f ∈ X →Q Y"
    shows "g ∈ X →Q Y"
proof(rule qbs_morphismI)
  fix α
  assume 1:"α ∈ qbs_Mx X"
  have "g ∘ α = f ∘ α"
  proof
    fix x
    have "α x ∈ qbs_space X"
      using 1 qbs_decomp[of X] by auto
    thus "(g ∘ α) x = (f ∘ α) x"
      using assms(1) by simp
  qed
  thus "g ∘ α ∈ qbs_Mx Y"
    using 1 assms(2) by(simp add: qbs_morphism_def)
qed

lemma qbs_morphism_const:
  assumes "y ∈ qbs_space Y"
  shows "(λ_. y) ∈ X →Q Y"
  using assms by (auto intro: qbs_morphismI)


subsubsection ‹ Empty Space ›
definition empty_quasi_borel  :: "'a quasi_borel" where
"empty_quasi_borel ≡ Abs_quasi_borel ({},{})"

lemma eqb_correct: "Rep_quasi_borel empty_quasi_borel = ({}, {})"
  using Abs_quasi_borel_inverse
  by(auto simp add: Abs_quasi_borel_inverse empty_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def is_quasi_borel_def)

lemma eqb_space[simp]: "qbs_space empty_quasi_borel = {}"
  by(simp add: qbs_space_def eqb_correct)

lemma eqb_Mx[simp]: "qbs_Mx empty_quasi_borel = {}"
  by(simp add: qbs_Mx_def eqb_correct)

lemma qbs_empty_equiv :"qbs_space X = {} ⟷ qbs_Mx X = {}"
proof(auto)
  fix x
  assume "qbs_Mx X = {}"
     and h:"x ∈ qbs_space X"
  have "(λr. x) ∈ qbs_Mx X"
    using h by simp
  thus "False" using ‹qbs_Mx X = {}› by simp
qed

lemma empty_quasi_borel_iff:
  "qbs_space X = {} ⟷ X = empty_quasi_borel"
  by(auto intro!: qbs_eqI)

subsubsection ‹ Unit Space ›
definition unit_quasi_borel :: "unit quasi_borel" ("1Q") where
"unit_quasi_borel ≡ Abs_quasi_borel (UNIV,UNIV)"

lemma uqb_correct: "Rep_quasi_borel unit_quasi_borel = (UNIV,UNIV)"
  using Abs_quasi_borel_inverse
  by(auto simp add: unit_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def is_quasi_borel_def)

lemma uqb_space[simp]: "qbs_space unit_quasi_borel = {()}"
  by(simp add: qbs_space_def UNIV_unit uqb_correct)

lemma uqb_Mx[simp]: "qbs_Mx unit_quasi_borel = {λr. ()}"
  by(auto simp add: qbs_Mx_def uqb_correct)

lemma unit_quasi_borel_terminal:
 "∃! f. f ∈ X →Q unit_quasi_borel"
  by(fastforce simp: qbs_morphism_def)

definition to_unit_quasi_borel :: "'a ⇒ unit" ("!Q") where
"to_unit_quasi_borel ≡ (λ_.())"

lemma to_unit_quasi_borel_morphism :
 "!Q ∈ X →Q unit_quasi_borel"
  by(auto simp add: to_unit_quasi_borel_def qbs_morphism_def)

subsubsection ‹ Subspaces ›
definition sub_qbs :: "['a quasi_borel, 'a set] ⇒ 'a quasi_borel" where
"sub_qbs X U ≡ Abs_quasi_borel (qbs_space X ∩ U,{f ∈ UNIV → qbs_space X ∩ U. f ∈ qbs_Mx X})"

lemma sub_qbs_closed:
  "qbs_closed1 {f ∈ UNIV → qbs_space X ∩ U. f ∈ qbs_Mx X}"
  "qbs_closed2 (qbs_space X ∩ U) {f ∈ UNIV → qbs_space X ∩ U. f ∈ qbs_Mx X}"
  "qbs_closed3 {f ∈ UNIV → qbs_space X ∩ U. f ∈ qbs_Mx X}"
  unfolding qbs_closed1_def qbs_closed2_def qbs_closed3_def by auto

lemma sub_qbs_correct[simp]: "Rep_quasi_borel (sub_qbs X U) = (qbs_space X ∩ U,{f ∈ UNIV → qbs_space X ∩ U. f ∈ qbs_Mx X})"
  by(simp add: Abs_quasi_borel_inverse sub_qbs_def sub_qbs_closed)

lemma sub_qbs_space[simp]: "qbs_space (sub_qbs X U) = qbs_space X ∩ U"
  by(simp add: qbs_space_def)

lemma sub_qbs_Mx[simp]: "qbs_Mx (sub_qbs X U) = {f ∈ UNIV → qbs_space X ∩ U. f ∈ qbs_Mx X}"
  by(simp add: qbs_Mx_def)

lemma sub_qbs:
  assumes "U ⊆ qbs_space X"
  shows "(qbs_space (sub_qbs X U), qbs_Mx (sub_qbs X U)) = (U, {f ∈ UNIV → U. f ∈ qbs_Mx X})"
  using assms by auto


subsubsection ‹ Image Spaces ›
definition map_qbs :: "['a ⇒ 'b] ⇒ 'a quasi_borel ⇒ 'b quasi_borel" where
"map_qbs f X = Abs_quasi_borel (f ` (qbs_space X),{β. ∃α∈ qbs_Mx X. β = f ∘ α})"

lemma map_qbs_f:
 "{β. ∃α∈ qbs_Mx X. β = f ∘ α} ⊆ UNIV → f ` (qbs_space X)"
  by fastforce

lemma map_qbs_closed1:
 "qbs_closed1 {β. ∃α∈ qbs_Mx X. β = f ∘ α}"
  unfolding qbs_closed1_def
  using qbs_closed1_dest by(fastforce simp: comp_def)

lemma map_qbs_closed2:
 "qbs_closed2 (f ` (qbs_space X)) {β. ∃α∈ qbs_Mx X. β = f ∘ α}"
  unfolding qbs_closed2_def by fastforce

lemma map_qbs_closed3:
 "qbs_closed3 {β. ∃α∈ qbs_Mx X. β = f ∘ α}"
proof(auto simp add: qbs_closed3_def)
  fix P Fi
  assume h:"∀i::nat. P -` {i} ∈ sets real_borel"
           "∀i::nat. ∃α∈qbs_Mx X. Fi i = f ∘ α"
  then obtain αi
    where ha: "∀i::nat. αi i ∈ qbs_Mx X ∧  Fi i = f ∘ (αi i)"
    by metis
  hence 1:"(λr. αi (P r) r) ∈ qbs_Mx X"
    using h(1) by fastforce
  show "∃α∈qbs_Mx X. (λr. Fi (P r) r) = f ∘ α"
    by(auto intro!: bexI[where x="(λr. αi (P r) r)"] simp add: 1 ha comp_def)
qed

lemma map_qbs_correct[simp]:
 "Rep_quasi_borel (map_qbs f X) = (f ` (qbs_space X),{β. ∃α∈ qbs_Mx X. β = f ∘ α})"
  unfolding map_qbs_def
  by(simp add: Abs_quasi_borel_inverse map_qbs_f map_qbs_closed1 map_qbs_closed2 map_qbs_closed3)

lemma map_qbs_space[simp]:
 "qbs_space (map_qbs f X) = f ` (qbs_space X)"
  by(simp add: qbs_space_def)

lemma map_qbs_Mx[simp]:
 "qbs_Mx (map_qbs f X) = {β. ∃α∈ qbs_Mx X. β = f ∘ α}"
  by(simp add: qbs_Mx_def)


inductive_set generating_Mx :: "'a set ⇒ (real ⇒ 'a) set ⇒ (real ⇒ 'a) set"
  for X :: "'a set" and Mx :: "(real ⇒ 'a) set"
  where
    Basic: "α ∈ Mx ⟹ α ∈ generating_Mx X Mx"
  | Const: "x ∈ X ⟹ (λr. x) ∈ generating_Mx X Mx"
  | Comp : "f ∈ real_borel →M real_borel ⟹ α ∈ generating_Mx X Mx ⟹ α ∘ f ∈ generating_Mx X Mx"
  | Part : "(⋀i. Fi i ∈ generating_Mx X Mx) ⟹ P ∈ real_borel →M nat_borel ⟹ (λr. Fi (P r) r) ∈ generating_Mx X Mx"

lemma generating_Mx_to_space:
  assumes "Mx ⊆ UNIV → X"
  shows "generating_Mx X Mx ⊆ UNIV → X"
proof
  fix α
  assume "α ∈ generating_Mx X Mx"
  then show "α ∈ UNIV → X"
   by(induct rule: generating_Mx.induct) (use assms in auto)
qed

lemma generating_Mx_closed1:
 "qbs_closed1 (generating_Mx X Mx)"
  by (simp add: generating_Mx.Comp qbs_closed1I)

lemma generating_Mx_closed2:
 "qbs_closed2 X (generating_Mx X Mx)"
  by (simp add: generating_Mx.Const qbs_closed2I)

lemma generating_Mx_closed3:
 "qbs_closed3 (generating_Mx X Mx)"
  by(simp add: qbs_closed3I' generating_Mx.Part)

lemma generating_Mx_Mx:
 "generating_Mx (qbs_space X) (qbs_Mx X) = qbs_Mx X"
proof auto
  fix α
  assume "α ∈ generating_Mx (qbs_space X) (qbs_Mx X)"
  then show "α ∈ qbs_Mx X"
    by(rule generating_Mx.induct) (auto intro!: qbs_closed1_dest[simplified comp_def] simp: qbs_closed3_dest')
next
  fix α
  assume "α ∈ qbs_Mx X"
  then show "α ∈ generating_Mx (qbs_space X) (qbs_Mx X)" ..
qed


subsubsection ‹ Ordering of Quasi-Borel Spaces ›

instantiation quasi_borel :: (type) order_bot
begin

inductive less_eq_quasi_borel :: "'a quasi_borel ⇒ 'a quasi_borel ⇒ bool" where
  "qbs_space X ⊂ qbs_space Y ⟹ less_eq_quasi_borel X Y"
| "qbs_space X = qbs_space Y ⟹ qbs_Mx Y ⊆ qbs_Mx X ⟹ less_eq_quasi_borel X Y"

lemma le_quasi_borel_iff:
 "X ≤ Y ⟷ (if qbs_space X = qbs_space Y then qbs_Mx Y ⊆ qbs_Mx X else qbs_space X ⊂ qbs_space Y)"
  by(auto elim: less_eq_quasi_borel.cases intro: less_eq_quasi_borel.intros)

definition less_quasi_borel :: "'a quasi_borel ⇒ 'a quasi_borel ⇒ bool" where
 "less_quasi_borel X Y ⟷ (X ≤ Y ∧ ¬ Y ≤ X)"

definition bot_quasi_borel :: "'a quasi_borel" where
 "bot_quasi_borel = empty_quasi_borel"

instance
proof
  show "bot ≤ a" for a :: "'a quasi_borel"
    using qbs_empty_equiv
    by(auto simp add: le_quasi_borel_iff bot_quasi_borel_def)
qed (auto simp: le_quasi_borel_iff less_quasi_borel_def split: if_split_asm intro: qbs_eqI)
end

definition inf_quasi_borel :: "['a quasi_borel, 'a quasi_borel] ⇒ 'a quasi_borel" where
"inf_quasi_borel X X' = Abs_quasi_borel (qbs_space X ∩ qbs_space X', qbs_Mx X ∩ qbs_Mx X')"

lemma inf_quasi_borel_correct: "Rep_quasi_borel (inf_quasi_borel X X') = (qbs_space X ∩ qbs_space X', qbs_Mx X ∩ qbs_Mx X')"
  by(fastforce intro!: Abs_quasi_borel_inverse
     simp: inf_quasi_borel_def is_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def)

lemma inf_qbs_space[simp]: "qbs_space (inf_quasi_borel X X') = qbs_space X ∩ qbs_space X'"
  by (simp add: qbs_space_def inf_quasi_borel_correct)

lemma inf_qbs_Mx[simp]: "qbs_Mx (inf_quasi_borel X X') = qbs_Mx X ∩ qbs_Mx X'"
  by(simp add: qbs_Mx_def inf_quasi_borel_correct)

definition max_quasi_borel :: "'a set ⇒ 'a quasi_borel" where
"max_quasi_borel X = Abs_quasi_borel (X, UNIV → X)"

lemma max_quasi_borel_correct: "Rep_quasi_borel (max_quasi_borel X) = (X, UNIV → X)"
  by(fastforce intro!: Abs_quasi_borel_inverse
   simp: max_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def is_quasi_borel_def)

lemma max_qbs_space[simp]: "qbs_space (max_quasi_borel X) = X"
  by(simp add: qbs_space_def max_quasi_borel_correct)

lemma max_qbs_Mx[simp]: "qbs_Mx (max_quasi_borel X) = UNIV → X"
  by(simp add: qbs_Mx_def max_quasi_borel_correct)

instantiation quasi_borel :: (type) semilattice_sup
begin

definition sup_quasi_borel :: "'a quasi_borel ⇒ 'a quasi_borel ⇒ 'a quasi_borel" where
"sup_quasi_borel X Y ≡ (if qbs_space X = qbs_space Y      then inf_quasi_borel X Y
                        else if qbs_space X ⊂ qbs_space Y then Y
                        else if qbs_space Y ⊂ qbs_space X then X
                        else max_quasi_borel (qbs_space X ∪ qbs_space Y))"


instance
proof
  fix X Y :: "'a quasi_borel"
  let ?X = "qbs_space X"
  let ?Y = "qbs_space Y"
  consider "?X = ?Y" | "?X ⊂ ?Y" | "?Y ⊂ ?X" | "?X ⊂ ?X ∪ ?Y ∧ ?Y ⊂ ?X ∪ ?Y"
    by auto
  then show "X ≤ X ⊔ Y"
  proof(cases)
    case 1
    show ?thesis
      unfolding sup_quasi_borel_def
      by(rule less_eq_quasi_borel.intros(2),simp_all add: 1)
  next
    case 2
    then show ?thesis
      unfolding sup_quasi_borel_def
      by (simp add: less_eq_quasi_borel.intros(1))
  next
    case 3
    then show ?thesis
      unfolding sup_quasi_borel_def
      by auto
  next
    case 4
    then show ?thesis
      unfolding sup_quasi_borel_def
      by(auto simp: less_eq_quasi_borel.intros(1))
  qed
next
  fix X Y :: "'a quasi_borel"
  let ?X = "qbs_space X"
  let ?Y = "qbs_space Y"
  consider "?X = ?Y" | "?X ⊂ ?Y" | "?Y ⊂ ?X" | "?X ⊂ ?X ∪ ?Y ∧ ?Y ⊂ ?X ∪ ?Y"
    by auto
  then show "Y ≤ X ⊔ Y"
  proof(cases)
    case 1
    show ?thesis
      unfolding sup_quasi_borel_def
      by(rule less_eq_quasi_borel.intros(2)) (simp_all add: 1)
  next
    case 2
    then show ?thesis
      unfolding sup_quasi_borel_def
      by auto
  next
    case 3
    then show ?thesis
      unfolding sup_quasi_borel_def
      by (auto simp add: less_eq_quasi_borel.intros(1))
  next
    case 4
    then show ?thesis
      unfolding sup_quasi_borel_def
      by(auto simp: less_eq_quasi_borel.intros(1))
  qed
next
  fix X Y Z :: "'a quasi_borel"
  assume h:"X ≤ Z" "Y ≤ Z"
  let ?X = "qbs_space X"
  let ?Y = "qbs_space Y"
  let ?Z = "qbs_space Z"
  consider "?X = ?Y" | "?X ⊂ ?Y" | "?Y ⊂ ?X" | "?X ⊂ ?X ∪ ?Y ∧ ?Y ⊂ ?X ∪ ?Y"
    by auto
  then show "sup X Y ≤ Z"
  proof cases
    case 1
    show ?thesis
      unfolding sup_quasi_borel_def
      apply(simp add: 1,rule less_eq_quasi_borel.cases[OF h(1)])
       apply(rule less_eq_quasi_borel.intros(1))
       apply auto[1]
      apply auto
      apply(rule less_eq_quasi_borel.intros(2))
       apply(simp add: 1)
      by(rule less_eq_quasi_borel.cases[OF h(2)]) (auto simp: 1)
  next
    case 2
    then show ?thesis
      unfolding sup_quasi_borel_def
      using h(2) by auto
  next
    case 3
    then show ?thesis
      unfolding sup_quasi_borel_def
      using h(1) by auto
  next
    case 4
    then have [simp]:"?X ≠ ?Y" "~ (?X ⊂ ?Y)" "~ (?Y ⊂ ?X)"
      by auto
    have [simp]:"?X ⊆ ?Z" "?Y ⊆ ?Z"
      by (metis h(1) dual_order.order_iff_strict less_eq_quasi_borel.cases)
         (metis h(2) dual_order.order_iff_strict less_eq_quasi_borel.cases)
    then consider "?X ∪ ?Y = ?Z" | "?X ∪ ?Y ⊂ ?Z"
      by blast
    then show ?thesis
      unfolding sup_quasi_borel_def
      apply cases
       apply simp
       apply(rule less_eq_quasi_borel.intros(2))
        apply simp
       apply auto[1]
      by(simp add: less_eq_quasi_borel.intros(1))
  qed
qed
end

end
le>

Theory Measure_QuasiBorel_Adjunction

(*  Title:   Measure_QuasiBorel_Adjunction.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsection ‹Relation to Measurable Spaces›

theory Measure_QuasiBorel_Adjunction
  imports "QuasiBorel"
begin

text ‹ We construct the adjunction between \textbf{Meas} and \textbf{QBS},
       where \textbf{Meas} is the category of measurable spaces and measurable functions
       and \textbf{QBS} is the category of quasi-Borel spaces and morphisms.›

subsubsection ‹ The Functor $R$ ›
definition measure_to_qbs :: "'a measure ⇒ 'a quasi_borel" where
"measure_to_qbs X ≡ Abs_quasi_borel (space X, real_borel →M X)"

lemma R_Mx_correct: "real_borel →M X ⊆ UNIV → space X"
  by (simp add: measurable_space subsetI)

lemma R_qbs_closed1: "qbs_closed1 (real_borel →M X)"
  by (simp add: qbs_closed1_def)

lemma R_qbs_closed2: "qbs_closed2 (space X) (real_borel →M X)"
  by (simp add: qbs_closed2_def)

lemma R_qbs_closed3: "qbs_closed3 (real_borel →M (X :: 'a measure))"
proof(rule qbs_closed3I)
  fix P::"real ⇒ nat"
  fix Fi::"nat ⇒ real ⇒ 'a"
  assume h:"⋀i. P -` {i} ∈ sets real_borel"
           "⋀i. Fi i ∈ real_borel →M X"
  show "(λr. Fi (P r) r) ∈ real_borel →M X"
  proof(rule measurableI)
    fix x
    assume "x ∈ space real_borel"
    then show "Fi (P x) x ∈ space X"
      using h(2) measurable_space[of "Fi (P x)" real_borel X x]
      by auto
  next
    fix A
    assume h':"A ∈ sets X"
    have "(λr. Fi (P r) r) -` A = (⋃i::nat. ((Fi i -` A) ∩ (P -` {i})))"
      by auto
    also have "... ∈ sets real_borel"
      using sets.Int measurable_sets[OF h(2) h'] h(1)
      by(auto intro!: countable_Un_Int(1))
    finally show "(λr. Fi (P r) r) -` A ∩ space real_borel ∈ sets real_borel"
      by simp
  qed
qed

lemma R_correct[simp]: "Rep_quasi_borel (measure_to_qbs X) = (space X, real_borel →M X)"
  unfolding measure_to_qbs_def
  by (rule Abs_quasi_borel_inverse) (simp add: R_Mx_correct R_qbs_closed1 R_qbs_closed2 R_qbs_closed3)

lemma qbs_space_R[simp]: "qbs_space (measure_to_qbs X) = space X"
  by (simp add: qbs_space_def)

lemma qbs_Mx_R[simp]: "qbs_Mx (measure_to_qbs X) = real_borel →M X"
  by (simp add: qbs_Mx_def)


text ‹ The following lemma says that @{term measure_to_qbs} is a functor from \textbf{Meas} to \textbf{QBS}. ›
lemma r_preserves_morphisms:
   "X →M Y ⊆ (measure_to_qbs X) →Q (measure_to_qbs Y)"
  by(auto intro!: qbs_morphismI)

subsubsection ‹ The Functor $L$ ›
definition sigma_Mx :: "'a quasi_borel ⇒ 'a set set" where
"sigma_Mx X ≡ {U ∩ qbs_space X |U. ∀α∈qbs_Mx X. α -` U ∈ sets real_borel}"

definition qbs_to_measure :: "'a quasi_borel ⇒ 'a measure" where
"qbs_to_measure X ≡ Abs_measure (qbs_space X, sigma_Mx X, λA. (if A = {} then 0 else if A ∈ - sigma_Mx X then 0 else ∞))"

lemma measure_space_L: "measure_space (qbs_space X) (sigma_Mx X) (λA. (if A = {} then 0 else if A ∈ - sigma_Mx X then 0 else ∞))"
  unfolding measure_space_def
proof auto

  show "sigma_algebra (qbs_space X) (sigma_Mx X)"
  proof(rule sigma_algebra.intro)
    show "algebra (qbs_space X) (sigma_Mx X)"
    proof
      have "∀ U ∈ sigma_Mx X. U ⊆ qbs_space X"
        using sigma_Mx_def subset_iff by fastforce
      thus "sigma_Mx X ⊆ Pow (qbs_space X)" by auto
    next
      show "{} ∈ sigma_Mx X"
        unfolding sigma_Mx_def by auto
    next
      fix A
      fix B
      assume "A ∈ sigma_Mx X"
             "B ∈ sigma_Mx X"
      then have "∃ Ua. A = Ua ∩ qbs_space X ∧ (∀α∈qbs_Mx X. α -` Ua ∈ sets real_borel)"
        by (simp add: sigma_Mx_def)
      then obtain Ua where pa:"A = Ua ∩ qbs_space X ∧ (∀α∈qbs_Mx X. α -` Ua ∈ sets real_borel)" by auto
      have "∃ Ub. B = Ub ∩ qbs_space X ∧ (∀α∈qbs_Mx X. α -` Ub ∈ sets real_borel)"
        using ‹B ∈ sigma_Mx X› sigma_Mx_def by auto
      then obtain Ub where pb:"B = Ub ∩ qbs_space X ∧ (∀α∈qbs_Mx X. α -` Ub ∈ sets real_borel)" by auto
      from pa pb have [simp]:"∀α∈qbs_Mx X. α -` (Ua ∩ Ub) ∈ sets real_borel"
        by auto
      from this pa pb sigma_Mx_def have [simp]:"(Ua ∩ Ub) ∩ qbs_space X ∈ sigma_Mx X" by blast
      from pa pb have [simp]:"A ∩ B = (Ua ∩ Ub) ∩ qbs_space X" by auto
      thus "A ∩ B ∈ sigma_Mx X" by simp
    next
      fix A
      fix B
      assume "A ∈ sigma_Mx X"
             "B ∈ sigma_Mx X"
      then have "∃ Ua. A = Ua ∩ qbs_space X ∧ (∀α∈qbs_Mx X. α -` Ua ∈ sets real_borel)"
        by (simp add: sigma_Mx_def)
      then obtain Ua where pa:"A = Ua ∩ qbs_space X ∧ (∀α∈qbs_Mx X. α -` Ua ∈ sets real_borel)" by auto
      have "∃ Ub. B = Ub ∩ qbs_space X ∧ (∀α∈qbs_Mx X. α -` Ub ∈ sets real_borel)"
        using ‹B ∈ sigma_Mx X› sigma_Mx_def by auto
      then obtain Ub where pb:"B = Ub ∩ qbs_space X ∧ (∀α∈qbs_Mx X. α -` Ub ∈ sets real_borel)" by auto
      from pa pb have [simp]:"A - B = (Ua ∩ -Ub) ∩ qbs_space X" by auto
      from pa pb have "∀α∈qbs_Mx X. α -`(Ua ∩ -Ub) ∈ sets real_borel"
        by (metis Diff_Compl double_compl sets.Diff vimage_Compl vimage_Int)
      hence 1:"A - B ∈ sigma_Mx X"
        using sigma_Mx_def ‹A - B = Ua ∩ - Ub ∩ qbs_space X› by blast
      show "∃C⊆sigma_Mx X. finite C ∧ disjoint C ∧ A - B = ⋃ C"
      proof
        show "{A - B} ⊆sigma_Mx X ∧ finite {A-B} ∧ disjoint {A-B} ∧ A - B = ⋃ {A-B}"
          using 1 by auto
      qed
    next
      fix A
      fix B
      assume "A ∈ sigma_Mx X"
             "B ∈ sigma_Mx X"
      then have "∃ Ua. A = Ua ∩ qbs_space X ∧ (∀α∈qbs_Mx X. α -` Ua ∈ sets real_borel)"
        by (simp add: sigma_Mx_def)
      then obtain Ua where pa:"A = Ua ∩ qbs_space X ∧ (∀α∈qbs_Mx X. α -` Ua ∈ sets real_borel)" by auto
      have "∃ Ub. B = Ub ∩ qbs_space X ∧ (∀α∈qbs_Mx X. α -` Ub ∈ sets real_borel)"
        using ‹B ∈ sigma_Mx X› sigma_Mx_def by auto
      then obtain Ub where pb:"B = Ub ∩ qbs_space X ∧ (∀α∈qbs_Mx X. α -` Ub ∈ sets real_borel)" by auto
      from pa pb have "A ∪ B = (Ua ∪ Ub) ∩ qbs_space X" by auto
      from pa pb have "∀α∈qbs_Mx X. α -`(Ua ∪ Ub) ∈ sets real_borel" by auto
      then show "A ∪ B ∈ sigma_Mx X"
        unfolding sigma_Mx_def
        using ‹A ∪ B = (Ua ∪ Ub) ∩ qbs_space X› by blast
    next
      have "∀α∈qbs_Mx X. α -` (UNIV) ∈ sets real_borel"
        by simp
      thus "qbs_space X ∈ sigma_Mx X"
        unfolding sigma_Mx_def
        by blast
    qed
  next
    show "sigma_algebra_axioms (sigma_Mx X)"
      unfolding sigma_algebra_axioms_def
    proof(auto)
      fix A :: "nat ⇒ _"
      assume 1:"range A ⊆ sigma_Mx X"
      then have 2:"∀i. ∃Ui. A i = Ui ∩ qbs_space X ∧ (∀α∈qbs_Mx X. α -` Ui ∈ sets real_borel)"
        unfolding sigma_Mx_def by auto
      then have "∃ U :: nat ⇒ _. ∀i. A i = U i ∩ qbs_space X ∧ (∀α∈qbs_Mx X. α -` (U i) ∈ sets real_borel)"
        by (rule choice)
      from this obtain U where pu:"∀i. A i = U i ∩ qbs_space X ∧ (∀α∈qbs_Mx X. α -` (U i) ∈ sets real_borel)"
        by auto
      hence "∀α∈qbs_Mx X. α -` (⋃ (range U)) ∈ sets real_borel"
        by (simp add: countable_Un_Int(1) vimage_UN)
      from pu have "⋃ (range A) = (⋃i::nat. (U i ∩ qbs_space X))" by blast
      hence "⋃ (range A) = ⋃ (range U) ∩ qbs_space X" by auto
      thus "⋃ (range A) ∈ sigma_Mx X"
        using sigma_Mx_def ‹∀α∈qbs_Mx X. α -` ⋃ (range U) ∈ sets real_borel› by blast
    qed
  qed
next
  show "countably_additive (sigma_Mx X) (λA. if A = {} then 0 else if A ∈ - sigma_Mx X then 0 else ∞)"
  proof(rule countably_additiveI)
    fix A :: "nat ⇒ _"
    assume h:"range A ⊆ sigma_Mx X"
             "⋃ (range A) ∈ sigma_Mx X"
    consider "⋃ (range A) = {}" | "⋃ (range A) ≠ {}"
      by auto
    then show "(∑i. if A i = {} then 0 else if A i ∈ - sigma_Mx X then 0 else ∞) =
               (if ⋃ (range A) = {} then 0 else if ⋃ (range A) ∈ - sigma_Mx X then 0 else (∞ :: ennreal))"
    proof cases
      case 1
      then have "⋀i. A i = {}"
        by simp
      thus ?thesis
        by(simp add: 1)
    next
      case 2
      then obtain j where hj:"A j ≠ {}"
        by auto
      have "(∑i. if A i = {} then 0  else if A i ∈ - sigma_Mx X then 0 else ∞) = (∞ :: ennreal)"
      proof -
        have hsum:"⋀N f. sum f {..<N} ≤ (∑n. (f n :: ennreal))"
          by (simp add: sum_le_suminf)
        have hsum':"⋀P f. (∃j. j ∈ P ∧ f j = (∞ :: ennreal)) ⟹ finite P ⟹ sum f P = ∞"
          by auto
        have h1:"(∑i<j+1. if A i = {} then 0 else if A i ∈ - sigma_Mx X then 0 else ∞) = (∞ :: ennreal)"
        proof(rule hsum')
          show "∃ja. ja ∈ {..<j + 1} ∧ (if A ja = {} then 0 else if A ja ∈ - sigma_Mx X then 0 else ∞) = (∞ :: ennreal)"
          proof(rule exI[where x=j],rule conjI)
            have "A j ∈ sigma_Mx X"
              using h(1) by auto
            then show "(if A j = {} then 0 else if A j ∈ - sigma_Mx X then 0 else ∞) = (∞ :: ennreal)"
              using hj by simp
          qed simp
        qed simp
        have "(∑i<j+1. if A i = {} then 0 else if A i ∈ - sigma_Mx X then 0 else ∞) ≤ (∑i. if A i = {} then 0 else if A i ∈ - sigma_Mx X then 0 else (∞ :: ennreal))"
          by(rule hsum)
        thus ?thesis
          by(simp only: h1) (simp add: top.extremum_unique)
      qed
      moreover have "(if ⋃ (range A) = {} then 0 else if ⋃ (range A) ∈ - sigma_Mx X then 0 else ∞) = (∞ :: ennreal)"
        using 2 h(2) by simp
      ultimately show ?thesis
        by simp
    qed
  qed
qed(simp add: positive_def)


lemma L_correct[simp]:"Rep_measure (qbs_to_measure X) = (qbs_space X, sigma_Mx X, λA. (if A = {} then 0 else if A ∈ - sigma_Mx X then 0 else ∞))"
  unfolding qbs_to_measure_def
  by(auto intro!: Abs_measure_inverse simp: measure_space_L)

lemma space_L[simp]: "space (qbs_to_measure X) = qbs_space X"
  by (simp add: space_def)

lemma sets_L[simp]: "sets (qbs_to_measure X) = sigma_Mx X"
  by (simp add: sets_def)

lemma emeasure_L[simp]: "emeasure (qbs_to_measure X) = (λA. if A = {} ∨ A ∉ sigma_Mx X then 0 else ∞)"
  by(auto simp: emeasure_def)

lemma qbs_Mx_sigma_Mx_contra:
  assumes "qbs_space X = qbs_space Y"
      and "qbs_Mx X ⊆ qbs_Mx Y"
  shows "sigma_Mx Y ⊆ sigma_Mx X"
  using assms by(auto simp: sigma_Mx_def)


text ‹ The following lemma says that @{term qbs_to_measure} is a functor from \textbf{QBS} to \textbf{Meas}. ›
lemma l_preserves_morphisms:
  "X →Q Y ⊆ (qbs_to_measure X) →M (qbs_to_measure Y)"
proof(auto)
  fix f
  assume h:"f ∈ X →Q Y"
  show "f ∈ (qbs_to_measure X) →M (qbs_to_measure Y)"
  proof(rule measurableI)
    fix x
    assume "x ∈ space (qbs_to_measure X)"
    then show "f x ∈ space (qbs_to_measure Y)"
      using h by auto
  next
    fix A
    assume "A ∈ sets (qbs_to_measure Y)"
    then obtain Ua where pa:"A = Ua ∩ qbs_space Y ∧ (∀α∈qbs_Mx Y. α -` Ua ∈ sets real_borel)"
      by (auto simp: sigma_Mx_def)
    have "∀α∈qbs_Mx X. f ∘ α ∈ qbs_Mx Y"
         "∀α∈ qbs_Mx X. α -` (f -` (qbs_space Y)) = UNIV"
      using h by auto
    hence "∀α∈qbs_Mx X. α -` (f -` A) = α -` (f -` Ua)"
      by (simp add: pa)
    from pa this qbs_morphism_def have "∀α∈qbs_Mx X. α -` (f -` A) ∈ sets real_borel"
      by (simp add: vimage_comp ‹∀α∈qbs_Mx X. f ∘ α ∈ qbs_Mx Y›)
    thus "f -` A ∩ space (qbs_to_measure X) ∈ sets (qbs_to_measure X)"
      using sigma_Mx_def by auto
  qed
qed


abbreviation "qbs_borel ≡ measure_to_qbs borel"

declare [[coercion measure_to_qbs]]

abbreviation real_quasi_borel :: "real quasi_borel" ("ℝQ") where
"real_quasi_borel ≡ qbs_borel"
abbreviation nat_quasi_borel :: "nat quasi_borel" ("ℕQ") where
"nat_quasi_borel ≡ qbs_borel"
abbreviation ennreal_quasi_borel :: "ennreal quasi_borel" ("ℝQ≥0") where
"ennreal_quasi_borel ≡ qbs_borel"
abbreviation bool_quasi_borel :: "bool quasi_borel" ("𝔹Q") where
"bool_quasi_borel ≡ qbs_borel"


lemma qbs_Mx_is_morphisms:
 "qbs_Mx X = real_quasi_borel →Q X"
proof(auto)
  fix α
  assume "α ∈ qbs_Mx X"
  then have "α ∈ UNIV → qbs_space X ∧ (∀ f ∈ real_borel →M real_borel. α ∘ f ∈ qbs_Mx X)"
    by fastforce
  thus "α ∈ real_quasi_borel →Q X"
    by(simp add: qbs_morphism_def)
next
  fix α
  assume "α ∈ real_quasi_borel →Q X"
  have "id ∈ qbs_Mx real_quasi_borel" by simp
  then have "α ∘ id ∈ qbs_Mx X"
    using ‹α ∈ real_quasi_borel →Q X› qbs_morphism_def[of real_quasi_borel X]
    by blast
  then show "α ∈ qbs_Mx X" by simp
qed

lemma qbs_Mx_subset_of_measurable:
  "qbs_Mx X ⊆ real_borel →M qbs_to_measure X"
proof
  fix α
  assume "α ∈ qbs_Mx X"
  show "α ∈ real_borel →M qbs_to_measure X"
  proof(rule measurableI)
    fix x
    show "α x ∈ space (qbs_to_measure X)"
      using qbs_decomp ‹α ∈ qbs_Mx X› by auto
  next
    fix A
    assume "A ∈ sets (qbs_to_measure X)"
    then have "α -`(qbs_space X) = UNIV"
      using ‹α ∈ qbs_Mx X› qbs_decomp by auto
    then show "α -` A ∩ space real_borel ∈ sets real_borel"
      using ‹α ∈ qbs_Mx X› ‹A ∈ sets (qbs_to_measure X)›
      by(auto simp add: sigma_Mx_def)
  qed
qed

lemma L_max_of_measurables:
  assumes "space M = qbs_space X"
      and "qbs_Mx X ⊆ real_borel →M M"
    shows "sets M ⊆ sets (qbs_to_measure X)"
proof
  fix U
  assume "U ∈ sets M"
  from sets.sets_into_space[OF this] in_mono[OF assms(2)] measurable_sets_borel[OF _ this]
  show "U ∈ sets (qbs_to_measure X)"
    using assms(1)
    by(auto intro!: exI[where x=U] simp: sigma_Mx_def)
qed


lemma qbs_Mx_are_measurable[simp,measurable]:
  assumes "α ∈ qbs_Mx X"
  shows "α ∈ real_borel →M qbs_to_measure X"
  using assms qbs_Mx_subset_of_measurable by auto

lemma measure_to_qbs_cong_sets:
  assumes "sets M = sets N"
  shows "measure_to_qbs M = measure_to_qbs N"
  by(rule qbs_eqI) (simp add: measurable_cong_sets[OF _ assms])

lemma lr_sets[simp,measurable_cong]:
 "sets X ⊆ sets (qbs_to_measure (measure_to_qbs X))"
proof auto
  fix U
  assume "U ∈ sets X"
  then have "U ∩ space X = U" by simp
  moreover have "∀α∈real_borel →M X. α -` U ∈ sets real_borel"
    using ‹U ∈ sets X› by(auto simp add: measurable_def)
  ultimately show "U ∈ sigma_Mx (measure_to_qbs X)"
    by(auto simp add: sigma_Mx_def)
qed

lemma(in standard_borel) standard_borel_lr_sets_ident[simp, measurable_cong]:
 "sets (qbs_to_measure (measure_to_qbs M)) = sets M"
proof auto
  fix V
  assume "V ∈ sigma_Mx (measure_to_qbs M)"
  then obtain U where H2: "V = U ∩ space M ∧ (∀α∈real_borel →M M. α -` U ∈ sets real_borel)"
    by(auto simp: sigma_Mx_def)
  hence "g -` V = g -` (U ∩ space M)" by auto
  have "... = g -` U" using g_meas by(auto simp add: measurable_def) 
  hence "f -` g -` U  ∩ space M ∈ sets M"
    by (meson f_meas g_meas measurable_sets H2)
  moreover have "f -` g -` U  ∩ space M  =  U ∩ space M"
    by auto
  ultimately show "V ∈ sets M" using H2 by simp
next
  fix U
  assume "U ∈ sets M"
  then show "U ∈ sigma_Mx (measure_to_qbs M)"
    using lr_sets by auto
qed


subsubsection ‹ The Adjunction ›
lemma  lr_adjunction_correspondence :
 "X →Q (measure_to_qbs Y) = (qbs_to_measure X) →M Y"
proof(auto)
(* ⊆ *)
  fix f
  assume "f ∈ X →Q (measure_to_qbs Y)"
  show "f ∈ qbs_to_measure X →M Y"
  proof(rule measurableI)
    fix x
    assume "x ∈ space (qbs_to_measure X)"
    hence "x ∈ qbs_space X" by simp
    thus "f x ∈ space Y"
      using ‹f ∈ X →Q (measure_to_qbs Y)› qbs_morphismE[of f X "measure_to_qbs Y"]
      by auto
  next
    fix A
    assume "A ∈ sets Y"
    have "∀α ∈ qbs_Mx X. f ∘ α ∈ qbs_Mx (measure_to_qbs Y)"
      using ‹f ∈ X →Q (measure_to_qbs Y)› by auto
    hence "∀α ∈ qbs_Mx X. f ∘ α ∈ real_borel →M Y" by simp
    hence "∀α ∈ qbs_Mx X. α -` (f -` A) ∈ sets real_borel"
      using ‹A∈ sets Y› measurable_sets_borel vimage_comp by metis
    thus "f -` A ∩ space (qbs_to_measure X) ∈ sets (qbs_to_measure X)"
      using sigma_Mx_def by auto
  qed
   
(* ⊇ *)
next
  fix f
  assume "f ∈ qbs_to_measure X →M Y"
  show "f ∈ X →Q measure_to_qbs Y"
  proof(rule qbs_morphismI,simp)
    fix α
    assume "α ∈ qbs_Mx X"
    show "f ∘ α ∈ real_borel →M Y"
    proof(rule measurableI)
      fix x
      assume "x ∈ space real_borel"
      from this ‹α ∈ qbs_Mx X ›qbs_decomp have "α x ∈ qbs_space X" by auto
      hence "α x ∈ space (qbs_to_measure X)" by simp
      thus "(f ∘ α) x ∈ space Y"
        using ‹f ∈ qbs_to_measure X →M Y›
        by (metis comp_def measurable_space)
    next
      fix A
      assume "A ∈ sets Y"
      from ‹f ∈ qbs_to_measure X →M Y› measurable_sets this measurable_def
      have "f -` A ∩ space (qbs_to_measure X) ∈ sets (qbs_to_measure X)"
        by blast
      hence "f -` A ∩ qbs_space X ∈ sigma_Mx X" by simp
      then have "∃ V. f -` A ∩ qbs_space X = V ∩ qbs_space X ∧ (∀β∈ qbs_Mx X. β -` V ∈ sets real_borel)"
        by (simp add:sigma_Mx_def)
      then obtain V where h:"f -` A ∩ qbs_space X = V ∩ qbs_space X ∧ (∀β∈ qbs_Mx X. β -` V ∈ sets real_borel)" by auto
      have 1:"α -` (f -` A) = α -` (f -` A ∩ qbs_space X)"
        using ‹α ∈ qbs_Mx X› by blast
      have 2:"α -` (V ∩ qbs_space X) = α -` V"
        using ‹α ∈ qbs_Mx X› by blast
      from 1 2 h have "(f ∘ α) -` A = α -` V" by (simp add: vimage_comp)
      from this h ‹α ∈ qbs_Mx X ›show "(f ∘ α) -` A ∩ space real_borel ∈ sets real_borel" by simp
    qed
  qed
qed

lemma(in standard_borel) standard_borel_r_full_faithful:
  "M →M Y = measure_to_qbs M →Q measure_to_qbs Y"
proof(standard;standard)
  fix h
  assume "h ∈ M →M Y"
  then show "h ∈ measure_to_qbs M →Q measure_to_qbs Y"
    using r_preserves_morphisms by auto
next
  fix h
  assume h:"h ∈ measure_to_qbs M →Q measure_to_qbs Y"
  show "h ∈ M →M Y"
  proof(rule measurableI)
    fix x
    assume "x ∈ space M"
    then show "h x ∈ space Y"
      using h by auto
  next
    fix U
    assume "U ∈ sets Y"
    have "h ∘ g ∈ real_borel →M Y"
      using ‹h ∈ measure_to_qbs M →Q measure_to_qbs Y›
      by(simp add: qbs_morphism_def)
    hence "(h ∘ g) -` U ∈ sets real_borel"
      by (simp add: ‹U ∈ sets Y› measurable_sets_borel)
    hence "f -` ((h ∘ g) -` U) ∩ space M ∈ sets M"
      using f_meas in_borel_measurable_borel by blast
    moreover have "f -` ((h ∘ g) -` U) ∩ space M = h -` U ∩ space M"
      using f_meas by auto
    ultimately show "h -` U ∩ space M ∈ sets M" by simp
  qed
qed

lemma qbs_morphism_dest[dest]:
  assumes "f ∈ X →Q measure_to_qbs Y"
  shows "f ∈ qbs_to_measure X →M Y"
  using assms lr_adjunction_correspondence by auto

lemma(in standard_borel) qbs_morphism_dest[dest]:
  assumes "k ∈ measure_to_qbs M →Q measure_to_qbs Y"
  shows "k ∈ M →M Y"
  using standard_borel_r_full_faithful assms by auto

lemma qbs_morphism_measurable_intro[intro!]:
  assumes "f ∈ qbs_to_measure X →M Y"
  shows "f ∈ X →Q measure_to_qbs Y"
  using assms lr_adjunction_correspondence by auto

lemma(in standard_borel) qbs_morphism_measurable_intro[intro!]:
  assumes "k ∈ M →M Y"
  shows "k ∈ measure_to_qbs M →Q measure_to_qbs Y"
  using standard_borel_r_full_faithful assms by auto

text ‹ We can use the measurability prover when we reason about morphisms. ›
lemma
  assumes "f ∈ ℝQ →Q ℝQ"
  shows "(λx. 2 * f x + (f x)^2) ∈ ℝQ →Q ℝQ"
  using assms by auto

lemma
  assumes "f ∈ X →Q ℝQ"
      and "α ∈ qbs_Mx X"
    shows "(λx. 2 * f (α x) + (f (α x))^2) ∈ ℝQ →Q ℝQ"
  using assms by auto


lemma qbs_morphisn_from_countable:
  fixes X :: "'a quasi_borel"
  assumes "countable (qbs_space X)"
          "qbs_Mx X ⊆ real_borel →M count_space (qbs_space X)"
      and "⋀i. i ∈ qbs_space X ⟹ f i ∈ qbs_space Y"
    shows "f ∈ X →Q Y"
proof(rule qbs_morphismI)
  fix α
  assume "α ∈ qbs_Mx X"
  then have [measurable]: "α ∈ real_borel →M count_space (qbs_space X)"
    using assms(2) ..
  define k :: "'a ⇒ real ⇒ _"
    where "k ≡ (λi _. f i)"
  have "f ∘ α = (λr. k (α r) r)"
    by(auto simp add: k_def)
  also have "... ∈ qbs_Mx Y"
    by(rule qbs_closed3_dest2[OF assms(1)]) (use assms(3) k_def in simp_all)
  finally show "f ∘ α ∈ qbs_Mx Y" .
qed

corollary nat_qbs_morphism:
  assumes "⋀n. f n ∈ qbs_space Y"
  shows "f ∈ ℕQ →Q Y"
  using assms measurable_cong_sets[OF refl sets_borel_eq_count_space,of real_borel]
  by(auto intro!: qbs_morphisn_from_countable)

corollary bool_qbs_morphism:
  assumes "⋀b. f b ∈ qbs_space Y"
  shows "f ∈ 𝔹Q →Q Y"
  using assms measurable_cong_sets[OF refl sets_borel_eq_count_space,of real_borel]
  by(auto intro!: qbs_morphisn_from_countable)


subsubsection ‹ The Adjunction w.r.t. Ordering›
lemma l_mono:
 "mono qbs_to_measure"
  apply standard
  subgoal for X Y
  proof(induction rule: less_eq_quasi_borel.induct)
    case (1 X Y)
    then show ?case
      by(simp add: less_eq_measure.intros(1))
  next
    case (2 X Y)
    then have "sigma_Mx X ⊆ sigma_Mx Y"
      by(auto simp add: sigma_Mx_def)
    then consider "sigma_Mx X ⊂ sigma_Mx Y" | "sigma_Mx X = sigma_Mx Y"
      by auto
    then show ?case
      apply(cases)
       apply(rule less_eq_measure.intros(2))
        apply(simp_all add: 2)
      by(rule less_eq_measure.intros(3),simp_all add: 2)
  qed
  done

lemma r_mono:
 "mono measure_to_qbs"
  apply standard
  subgoal for M N
  proof(induction rule: less_eq_measure.inducts)
    case (1 M N)
    then show ?case
      by(simp add: less_eq_quasi_borel.intros(1))
  next
    case (2 M N)
    then have "real_borel →M N ⊆ real_borel →M M"
      by(simp add: measurable_mono)
    then consider "real_borel →M N ⊂ real_borel →M M" | "real_borel →M N = real_borel →M M"
      by auto
    then show ?case
      by cases (rule less_eq_quasi_borel.intros(2),simp_all add: 2)+
  next
    case (3 M N)
    then show ?case
      apply -
      by(rule less_eq_quasi_borel.intros(2)) (simp_all add: measurable_mono)
  qed
  done

lemma rl_order_adjunction:
  "X ≤ qbs_to_measure Y ⟷ measure_to_qbs X ≤ Y"
proof
  assume 1: "X ≤ qbs_to_measure Y"
  then show "measure_to_qbs X ≤ Y"
  proof(induction rule: less_eq_measure.cases)
    case (1 M N)
    then have [simp]:"qbs_space Y = space N"
      by(simp add: 1(2)[symmetric])
    show ?case
      by(rule less_eq_quasi_borel.intros(1),simp add: 1)
  next
    case (2 M N)
    then have [simp]:"qbs_space Y = space N"
      by(simp add: 2(2)[symmetric])
    show ?case
    proof(rule less_eq_quasi_borel.intros(2),simp add:2,auto)
      fix α
      assume h:"α ∈ qbs_Mx Y"
      show "α ∈ real_borel →M X"
      proof(rule measurableI,simp_all)
        show "⋀x. α x ∈ space X"
          using h by (auto simp add: 2)
      next
        fix A
        assume "A ∈ sets X"
        then have "A ∈ sets (qbs_to_measure Y)"
          using 2 by auto
        then obtain U where
          hu:"A = U ∩ space N"
             "(∀α∈qbs_Mx Y. α -` U ∈ sets real_borel)"
          by(auto simp add: sigma_Mx_def)
        have "α -` A  = α -` U"
          using h qbs_decomp[of Y]
          by(auto simp add: hu)
        thus "α -` A ∈ sets borel"
          using h hu(2) by simp
      qed
    qed
  next
    case (3 M N)
    then have [simp]:"qbs_space Y = space N"
      by(simp add: 3(2)[symmetric])
    show ?case
    proof(rule less_eq_quasi_borel.intros(2),simp add: 3,auto)
      fix α
      assume h:"α ∈ qbs_Mx Y"
      show "α ∈ real_borel →M X"
      proof(rule measurableI,simp_all)
        show "⋀x. α x ∈ space X"
          using h by(auto simp: 3)
      next
        fix A
        assume "A ∈ sets X"
        then have "A ∈ sets (qbs_to_measure Y)"
          using 3 by auto
        then obtain U where
          hu:"A = U ∩ space N"
             "(∀α∈qbs_Mx Y. α -` U ∈ sets real_borel)"
          by(auto simp add: sigma_Mx_def)
        have "α -` A  = α -` U"
          using h qbs_decomp[of Y]
          by(auto simp add: hu)
        thus "α -` A ∈ sets borel"
          using h hu(2) by simp
      qed
    qed
  qed
next
  assume "measure_to_qbs X ≤ Y"
  then show "X ≤ qbs_to_measure Y"
  proof(induction rule: less_eq_quasi_borel.cases)
    case (1 A B)
    have [simp]: "space X = qbs_space A"
      by(simp add: 1(1)[symmetric])
    show ?case
      by(rule less_eq_measure.intros(1)) (simp add: 1)
  next
    case (2 A B)
    then have hmy:"qbs_Mx Y ⊆ real_borel →M X"
      by auto
    have [simp]: "space X = qbs_space A"
      by(simp add: 2(1)[symmetric])
    have "sets X ⊆ sigma_Mx Y"
    proof
      fix U
      assume hu:"U ∈ sets X"
      show "U ∈ sigma_Mx Y"
      proof(simp add: sigma_Mx_def,rule exI[where x=U],auto)
        show "⋀x. x ∈ U ⟹ x ∈ qbs_space Y"
          using sets.sets_into_space[OF hu]
          by(auto simp add: 2)
      next
        fix α
        assume "α ∈ qbs_Mx Y"
        then have "α ∈ real_borel →M X"
          using hmy by(auto)
        thus "α -` U ∈ sets real_borel"
          using hu by(simp add: measurable_sets_borel)
      qed
    qed
    then consider "sets X = sigma_Mx Y" | "sets X ⊂ sigma_Mx Y"
      by auto
    then show ?case
    proof cases
      case 1
      show ?thesis
        apply(rule less_eq_measure.intros(3),simp_all add: 1 2)
      proof(rule le_funI)
        fix U
        consider "U = {}" | "U ∉ sigma_Mx B" | "U ≠ {} ∧ U ∈ sigma_Mx B"
          by auto
        then show "emeasure X U ≤ (if U = {} ∨ U ∉ sigma_Mx B then 0 else ∞)"
        proof cases
          case 1
          then show ?thesis by simp
        next
          case h:2
          then have "U ∉ sigma_Mx A"
            using qbs_Mx_sigma_Mx_contra[OF 2(3)[symmetric] 2(4)]
            by auto
          hence "U ∉ sets X"
            using lr_sets 2(1) by auto
          thus ?thesis
            by(simp add: h emeasure_notin_sets)
        next
          case 3
          then show ?thesis
            by simp
        qed
      qed
    next
      case h2:2
      show ?thesis
        by(rule less_eq_measure.intros(2)) (simp add: 2,simp add: h2)
    qed
  qed
qed

end

Theory Binary_Product_QuasiBorel

(*  Title:   Binary_Product_QuasiBorel.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsection ‹Product Spaces›

theory Binary_Product_QuasiBorel
  imports "Measure_QuasiBorel_Adjunction"
begin

subsubsection ‹ Binary Product Spaces ›
definition pair_qbs_Mx :: "['a quasi_borel, 'b quasi_borel] ⇒ (real => 'a × 'b) set" where
"pair_qbs_Mx X Y ≡ {f. fst ∘ f ∈ qbs_Mx X ∧ snd ∘ f ∈ qbs_Mx Y}"

definition pair_qbs :: "['a quasi_borel, 'b quasi_borel] ⇒ ('a × 'b) quasi_borel" (infixr "⨂Q" 80) where
"pair_qbs X Y = Abs_quasi_borel (qbs_space X × qbs_space Y, pair_qbs_Mx X Y)"


lemma pair_qbs_f[simp]: "pair_qbs_Mx X Y ⊆ UNIV → qbs_space X × qbs_space Y"
  unfolding pair_qbs_Mx_def
  by (auto simp: mem_Times_iff[of _ "qbs_space X" "qbs_space Y"]; fastforce)

lemma pair_qbs_closed1: "qbs_closed1 (pair_qbs_Mx (X::'a quasi_borel) (Y::'b quasi_borel))"
  unfolding pair_qbs_Mx_def qbs_closed1_def
  by (metis (no_types, lifting) comp_assoc mem_Collect_eq qbs_closed1_dest)

lemma pair_qbs_closed2: "qbs_closed2 (qbs_space X × qbs_space Y) (pair_qbs_Mx X Y)"
  unfolding qbs_closed2_def pair_qbs_Mx_def
  by auto

lemma pair_qbs_closed3: "qbs_closed3 (pair_qbs_Mx (X::'a quasi_borel) (Y::'b quasi_borel))"
proof(auto simp add: qbs_closed3_def pair_qbs_Mx_def)
  fix P :: "real ⇒ nat"
  fix Fi :: "nat ⇒ real ⇒ 'a × 'b"
  define Fj :: "nat ⇒ real ⇒ 'a" where "Fj ≡ λj.(fst ∘ Fi j)"
  assume "∀i. fst ∘ Fi i ∈ qbs_Mx X ∧ snd ∘ Fi i ∈ qbs_Mx Y"
  then have "∀i. Fj i ∈ qbs_Mx X" by (simp add: Fj_def)
  moreover assume "∀i. P -` {i} ∈ sets real_borel"
  ultimately have "(λr. Fj (P r) r) ∈ qbs_Mx X"
    by auto
  moreover have "fst ∘ (λr. Fi (P r) r) = (λr. Fj (P r) r)" by (auto simp add: Fj_def)
  ultimately show "fst ∘ (λr. Fi (P r) r) ∈ qbs_Mx X" by simp
next
  fix P :: "real ⇒ nat"
  fix Fi :: "nat ⇒ real ⇒ 'a × 'b"
  define Fj :: "nat ⇒ real ⇒ 'b" where "Fj ≡ λj.(snd ∘ Fi j)"
  assume "∀i. fst ∘ Fi i ∈ qbs_Mx X ∧ snd ∘ Fi i ∈ qbs_Mx Y"
  then have "∀i. Fj i ∈ qbs_Mx Y" by (simp add: Fj_def)
  moreover assume "∀i. P -` {i} ∈ sets real_borel"
  ultimately have "(λr. Fj (P r) r) ∈ qbs_Mx Y"
    by auto
  moreover have "snd ∘ (λr. Fi (P r) r) = (λr. Fj (P r) r)" by (auto simp add: Fj_def)
  ultimately show "snd ∘ (λr. Fi (P r) r) ∈ qbs_Mx Y" by simp
qed

lemma pair_qbs_correct: "Rep_quasi_borel (X ⨂Q Y) = (qbs_space X × qbs_space Y, pair_qbs_Mx X Y)"
  unfolding pair_qbs_def
  by(auto intro!: Abs_quasi_borel_inverse pair_qbs_f simp: pair_qbs_closed3 pair_qbs_closed2 pair_qbs_closed1)

lemma pair_qbs_space[simp]: "qbs_space (X ⨂Q Y) = qbs_space X × qbs_space Y"
  by (simp add: qbs_space_def pair_qbs_correct)

lemma pair_qbs_Mx[simp]: "qbs_Mx (X ⨂Q Y) = pair_qbs_Mx X Y"
  by (simp add: qbs_Mx_def pair_qbs_correct)


lemma pair_qbs_morphismI:
  assumes "⋀α β. α ∈ qbs_Mx X ⟹ β ∈ qbs_Mx Y 
           ⟹ f ∘ (λr. (α r, β r)) ∈ qbs_Mx Z"
    shows "f ∈ (X ⨂Q Y) →Q Z"
proof(rule qbs_morphismI)
  fix α
  assume 1:"α ∈ qbs_Mx (X ⨂Q Y)"
  have "f ∘ α = f ∘ (λr. ((fst ∘ α) r, (snd ∘ α) r))"
    by auto
  also have "... ∈ qbs_Mx Z"
    using 1 assms[of "fst ∘ α" "snd ∘ α"]
    by(simp add: pair_qbs_Mx_def)
  finally show "f ∘ α ∈ qbs_Mx Z" .
qed


lemma fst_qbs_morphism:
  "fst ∈ X ⨂Q Y →Q X"
  by(auto simp add: qbs_morphism_def pair_qbs_Mx_def)

lemma snd_qbs_morphism:
  "snd ∈ X ⨂Q Y →Q Y"
  by(auto simp add: qbs_morphism_def pair_qbs_Mx_def)

lemma qbs_morphism_pair_iff:
 "f ∈ X →Q Y ⨂Q Z ⟷ fst ∘ f ∈ X →Q Y ∧ snd ∘ f ∈ X →Q Z"
  by(auto intro!: qbs_morphismI qbs_morphism_comp[OF _ fst_qbs_morphism,of f X Y Z ]qbs_morphism_comp[OF _ snd_qbs_morphism,of f X Y Z]
            simp: pair_qbs_Mx_def comp_assoc[symmetric])

lemma qbs_morphism_Pair1:
  assumes "x ∈ qbs_space X"
  shows "Pair x ∈ Y →Q X ⨂Q Y"
  using assms
  by(auto intro!: qbs_morphismI simp: pair_qbs_Mx_def comp_def)

lemma qbs_morphism_Pair1':
  assumes "x ∈ qbs_space X"
      and "f ∈ X ⨂Q Y →Q Z"
    shows "(λy. f (x,y)) ∈ Y →Q Z"
  using qbs_morphism_comp[OF qbs_morphism_Pair1[OF assms(1)] assms(2)]
  by(simp add: comp_def)

lemma qbs_morphism_Pair2:
  assumes "y ∈ qbs_space Y"
  shows "(λx. (x,y)) ∈ X →Q X ⨂Q Y"
  using assms
  by(auto intro!: qbs_morphismI simp: pair_qbs_Mx_def comp_def)

lemma qbs_morphism_Pair2':
  assumes "y ∈ qbs_space Y"
      and "f ∈ X ⨂Q Y →Q Z"
    shows "(λx. f (x,y)) ∈ X →Q Z"
  using qbs_morphism_comp[OF qbs_morphism_Pair2[OF assms(1)] assms(2)]
  by(simp add: comp_def)

lemma qbs_morphism_fst'':
  assumes "f ∈ X →Q Y"
  shows "(λk. f (fst k)) ∈ X ⨂Q Z →Q Y"
  using qbs_morphism_comp[OF fst_qbs_morphism assms,of Z]
  by(simp add: comp_def)

lemma qbs_morphism_snd'':
  assumes "f ∈ X →Q Y"
  shows "(λk. f (snd k)) ∈ Z ⨂Q X →Q Y"
  using qbs_morphism_comp[OF snd_qbs_morphism assms,of Z]
  by(simp add: comp_def)

lemma qbs_morphism_tuple:
  assumes "f ∈ Z →Q X"
      and "g ∈ Z →Q Y"
    shows "(λz. (f z, g z)) ∈ Z →Q X ⨂Q Y"
proof(rule qbs_morphismI,simp)
  fix α
  assume  h:"α ∈ qbs_Mx Z"
  then have "(λz. (f z, g z)) ∘ α ∈ UNIV → qbs_space X × qbs_space Y"
    using assms qbs_morphismE(2)[OF assms(1)] qbs_morphismE(2)[OF assms(2)]
    by fastforce
  moreover have "fst ∘ ((λz. (f z, g z)) ∘ α) = f ∘ α" by auto
  moreover have "... ∈ qbs_Mx X" 
    using assms(1) h by auto
  moreover have "snd ∘ ((λz. (f z, g z)) ∘ α) = g ∘ α" by auto
  moreover have "... ∈ qbs_Mx Y"
    using assms(2) h by auto
  ultimately show "(λz. (f z, g z)) ∘ α ∈ pair_qbs_Mx X Y"
    by (simp add: pair_qbs_Mx_def)
qed

lemma qbs_morphism_map_prod:
  assumes "f ∈ X →Q Y"
      and "g ∈ X' →Q Y'"
    shows "map_prod f g ∈ X ⨂Q X'→Q Y ⨂Q Y'"
proof(rule pair_qbs_morphismI)
  fix α β
  assume h:"α ∈ qbs_Mx X"
           "β ∈ qbs_Mx X'"
  have [simp]: "fst ∘ (map_prod f g ∘ (λr. (α r, β r))) = f ∘ α" by auto
  have [simp]: "snd ∘ (map_prod f g ∘ (λr. (α r, β r))) = g ∘ β" by auto
  show "map_prod f g ∘ (λr. (α r, β r)) ∈ qbs_Mx (Y ⨂Q Y')"
    using h assms by(auto simp: pair_qbs_Mx_def)
qed

lemma qbs_morphism_pair_swap':
  "(λ(x,y). (y,x)) ∈ (X::'a quasi_borel) ⨂Q (Y::'b quasi_borel) →Q Y ⨂Q X"
  by(auto intro!: qbs_morphismI simp: pair_qbs_Mx_def split_beta' comp_def)

lemma qbs_morphism_pair_swap:
  assumes "f ∈ X ⨂Q Y →Q Z"
  shows "(λ(x,y). f (y,x)) ∈ Y ⨂Q X →Q Z"
proof -
  have "(λ(x,y). f (y,x)) = f ∘ (λ(x,y). (y,x))" by auto
  thus ?thesis
    using qbs_morphism_comp[of "(λ(x,y). (y,x))" "Y ⨂Q X" _ f] qbs_morphism_pair_swap' assms
    by auto
qed

lemma qbs_morphism_pair_assoc1:
 "(λ((x,y),z). (x,(y,z))) ∈ (X ⨂Q Y) ⨂Q Z →Q X ⨂Q (Y ⨂Q Z)"
  by(auto intro!: qbs_morphismI simp: pair_qbs_Mx_def split_beta' comp_def)

lemma qbs_morphism_pair_assoc2:
 "(λ(x,(y,z)). ((x,y),z)) ∈ X ⨂Q (Y ⨂Q Z) →Q (X ⨂Q Y) ⨂Q Z"
  by(auto intro!: qbs_morphismI simp: pair_qbs_Mx_def split_beta' comp_def)

lemma pair_qbs_fst:
  assumes "qbs_space Y ≠ {}"
  shows "map_qbs fst (X ⨂Q Y) = X"
proof(rule qbs_eqI)
  show "qbs_Mx (map_qbs fst (X ⨂Q Y)) = qbs_Mx X"
  proof auto
    fix αx
    assume hx:"αx ∈ qbs_Mx X"
    obtain αy where hy:"αy ∈ qbs_Mx Y"
      using qbs_empty_equiv[of Y] assms
      by auto
    show "∃α∈pair_qbs_Mx X Y. αx = fst ∘ α"
      by(auto intro!: exI[where x="λr. (αx r, αy r)"] simp: pair_qbs_Mx_def hx hy comp_def)
  qed (simp add: pair_qbs_Mx_def)
qed

lemma pair_qbs_snd:
  assumes "qbs_space X ≠ {}"
  shows "map_qbs snd (X ⨂Q Y) = Y"
proof(rule qbs_eqI)
  show "qbs_Mx (map_qbs snd (X ⨂Q Y)) = qbs_Mx Y"
  proof auto
    fix αy
    assume hy:"αy ∈ qbs_Mx Y"
    obtain αx where hx:"αx ∈ qbs_Mx X"
      using qbs_empty_equiv[of X] assms
      by auto
    show "∃α∈pair_qbs_Mx X Y. αy = snd ∘ α"
      by(auto intro!: exI[where x="λr. (αx r, αy r)"] simp: pair_qbs_Mx_def hx hy comp_def)
  qed (simp add: pair_qbs_Mx_def)
qed

text ‹ The following lemma corresponds to \cite{Heunen_2017} Proposition 19(1). ›
lemma r_preserves_product :
  "measure_to_qbs (X ⨂M Y) = measure_to_qbs X ⨂Q measure_to_qbs Y"
  by(auto intro!: qbs_eqI simp: measurable_pair_iff pair_qbs_Mx_def)

lemma l_product_sets[simp,measurable_cong]:
  "sets (qbs_to_measure X ⨂M qbs_to_measure Y) ⊆ sets (qbs_to_measure (X ⨂Q Y))"
proof(rule sets_pair_in_sets,simp)
  fix A B
  assume h:"A ∈ sigma_Mx X"
           "B ∈ sigma_Mx Y"
  then obtain Ua Ub where hu:
   "A = Ua ∩ qbs_space X" "∀α∈qbs_Mx X. α -` Ua ∈ sets real_borel"
   "B = Ub ∩ qbs_space Y" "∀α∈qbs_Mx Y. α -` Ub ∈ sets real_borel"
    by(auto simp add: sigma_Mx_def)
  show "A × B ∈ sigma_Mx (X ⨂Q Y)"
  proof(simp add: sigma_Mx_def, rule exI[where x="Ua × Ub"])
    show "A × B = Ua × Ub ∩ qbs_space X × qbs_space Y ∧
    (∀α∈pair_qbs_Mx X Y. α -` (Ua × Ub) ∈ sets real_borel)"
      using hu by(auto simp add: pair_qbs_Mx_def vimage_Times)
  qed
qed

lemma(in pair_standard_borel) l_r_r_sets[simp,measurable_cong]:
 "sets (qbs_to_measure (measure_to_qbs M ⨂Q measure_to_qbs N)) = sets (M ⨂M N)"
  by(simp only: r_preserves_product[symmetric]) (rule standard_borel_lr_sets_ident)

end

Theory Product_QuasiBorel

(*  Title:   Product_QuasiBorel.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsubsection ‹ Product Spaces›
theory Product_QuasiBorel

imports "Binary_Product_QuasiBorel"

begin

definition prod_qbs_Mx :: "['a set, 'a ⇒ 'b quasi_borel] ⇒ (real ⇒ 'a ⇒ 'b) set" where
"prod_qbs_Mx I M ≡ { α | α. ∀i. (i ∈ I ⟶ (λr. α r i) ∈ qbs_Mx (M i)) ∧ (i ∉ I ⟶ (λr. α r i) = (λr. undefined))}"

lemma prod_qbs_MxI:
  assumes "⋀i. i ∈ I ⟹ (λr. α r i) ∈ qbs_Mx (M i)"
      and "⋀i. i ∉ I ⟹ (λr. α r i) = (λr. undefined)"
    shows "α ∈ prod_qbs_Mx I M"
  using assms by(auto simp: prod_qbs_Mx_def)

lemma prod_qbs_MxE:
  assumes "α ∈ prod_qbs_Mx I M"
  shows "⋀i. i ∈ I ⟹ (λr. α r i) ∈ qbs_Mx (M i)"
    and "⋀i. i ∉ I ⟹ (λr. α r i) = (λr. undefined)"
    and "⋀i r. i ∉ I ⟹ α r i = undefined"
  using assms by(auto simp: prod_qbs_Mx_def dest: fun_cong[where g="(λr. undefined)"])

definition PiQ :: "'a set ⇒ ('a ⇒ 'b quasi_borel) ⇒ ('a ⇒ 'b) quasi_borel" where
"PiQ I M ≡ Abs_quasi_borel (ΠE i∈I. qbs_space (M i), prod_qbs_Mx I M)"

syntax
  "_PiQ" :: "pttrn ⇒ 'i set ⇒ 'a quasi_borel ⇒ ('i => 'a) quasi_borel"  ("(3ΠQ _∈_./ _)"  10)
translations
  "ΠQ x∈I. M" == "CONST PiQ I (λx. M)"


lemma PiQ_f: "prod_qbs_Mx I M ⊆ UNIV → (ΠE i∈I. qbs_space (M i))"
  using prod_qbs_MxE by fastforce

lemma PiQ_closed1: "qbs_closed1 (prod_qbs_Mx I M)"
proof(rule qbs_closed1I)
  fix α f
  assume h:"α ∈ prod_qbs_Mx I M "
           "f ∈ real_borel →M real_borel"
  show "α ∘ f ∈ prod_qbs_Mx I M"
  proof(rule prod_qbs_MxI)
    fix i
    assume "i ∈ I"
    from prod_qbs_MxE(1)[OF h(1) this]
    have "(λr. α r i) ∘ f ∈ qbs_Mx (M i)"
      using h(2) by auto
    thus "(λr. (α ∘ f) r i) ∈ qbs_Mx (M i)"
      by(simp add: comp_def)
  next
    fix i
    assume "i ∉ I"
    from prod_qbs_MxE(3)[OF h(1) this]
    show "(λr. (α ∘ f) r i) = (λr. undefined)"
      by simp
  qed
qed

lemma PiQ_closed2: "qbs_closed2 (ΠE i∈I. qbs_space (M i)) (prod_qbs_Mx I M)"
proof(rule qbs_closed2I)
  fix x
  assume h:"x ∈ (ΠE i∈I. qbs_space (M i))"
  show "(λr. x) ∈ prod_qbs_Mx I M"
  proof(rule prod_qbs_MxI)
    fix i
    assume hi:"i ∈ I"
    then have "x i ∈ qbs_space (M i)"
      using h by auto
    thus "(λr. x i) ∈ qbs_Mx (M i)"
      by auto
  next
    show "⋀i. i ∉ I ⟹ (λr. x i) = (λr. undefined)"
      using h by auto
  qed
qed

lemma PiQ_closed3: "qbs_closed3 (prod_qbs_Mx I M)"
proof(rule qbs_closed3I)
  fix P Fi
  assume h:"⋀i::nat. P -` {i} ∈ sets real_borel"
           "⋀i::nat. Fi i ∈ prod_qbs_Mx I M"
  show "(λr. Fi (P r) r) ∈ prod_qbs_Mx I M"
  proof(rule prod_qbs_MxI)
    fix i
    assume hi:"i ∈ I"
    show "(λr. Fi (P r) r i) ∈ qbs_Mx (M i)"
      using prod_qbs_MxE(1)[OF h(2) hi] qbs_closed3_dest[OF h(1),of "λj r. Fi j r i"]
      by auto
  next
    show "⋀i. i ∉ I ⟹
         (λr. Fi (P r) r i) = (λr. undefined)"
      using prod_qbs_MxE[OF h(2)] by auto
  qed
qed

lemma PiQ_correct: "Rep_quasi_borel (PiQ I M) = (ΠE i∈I. qbs_space (M i), prod_qbs_Mx I M)"
  by(auto intro!: Abs_quasi_borel_inverse PiQ_f is_quasi_borel_intro simp: PiQ_def PiQ_closed1 PiQ_closed2 PiQ_closed3)

lemma PiQ_space[simp]: "qbs_space (PiQ I M) = (ΠE i∈I. qbs_space (M i))"
  by(simp add: qbs_space_def PiQ_correct)

lemma PiQ_Mx[simp]: "qbs_Mx (PiQ I M) = prod_qbs_Mx I M"
  by(simp add: qbs_Mx_def PiQ_correct)


lemma qbs_morphism_component_singleton:
  assumes "i ∈ I"
  shows "(λx. x i) ∈ (ΠQ i∈I. (M i)) →Q M i"
  by(auto intro!: qbs_morphismI simp: prod_qbs_Mx_def comp_def assms)

lemma product_qbs_canonical1:
  assumes "⋀i. i ∈ I ⟹ f i ∈ Y →Q X i"
      and "⋀i. i ∉ I ⟹ f i = (λy. undefined)"
    shows "(λy i. f i y) ∈ Y →Q (ΠQ i∈I. X i)"
  using qbs_morphismE(3)[simplified comp_def,OF assms(1)] assms(2)
  by(auto intro!: qbs_morphismI prod_qbs_MxI)

lemma product_qbs_canonical2:
  assumes "⋀i. i ∈ I ⟹ f i ∈ Y →Q X i"
          "⋀i. i ∉ I ⟹ f i = (λy. undefined)"
          "g ∈ Y →Q (ΠQ i∈I. X i)"
          "⋀i. i ∈ I ⟹ f i = (λx. x i) ∘ g"
      and "y ∈ qbs_space Y"
    shows "g y = (λi. f i y)"
proof(rule ext)+
  fix i
  show "g y i = f i y"
  proof(cases "i ∈ I")
    case True
    then show ?thesis
      using assms(4)[of i] by simp
  next
    case False
    moreover have "(λr. y) ∈ qbs_Mx Y"
      using assms(5) by simp
    ultimately show ?thesis
      using assms(2,3) qbs_morphismE(3)[OF assms(3) _]
      by(fastforce simp: prod_qbs_Mx_def)
  qed
qed

lemma merge_qbs_morphism:
 "merge I J ∈ (ΠQ i∈I. (M i)) ⨂Q (ΠQ j∈J. (M j)) →Q (ΠQ i∈I∪J. (M i))"
proof(rule qbs_morphismI)
  fix α
  assume h:"α ∈ qbs_Mx ((ΠQ i∈I. (M i)) ⨂Q (ΠQ j∈J. (M j)))"
  show "merge I J ∘ α ∈ qbs_Mx (ΠQ i∈I∪J. (M i))"
  proof(simp, rule prod_qbs_MxI)
    fix i
    assume "i ∈ I ∪ J"
    then consider "i ∈ I" | "i ∈ I ∧ i ∈ J" | "i ∉ I ∧ i ∈ J"
      by auto
    then show "(λr. (merge I J ∘ α) r i) ∈ qbs_Mx (M i)"
      apply cases
      using h
      by(auto simp: merge_def pair_qbs_Mx_def split_beta' dest: prod_qbs_MxE)
  next
    fix i
    assume "i ∉ I ∪ J"
    then show "(λr. (merge I J ∘ α) r i) = (λr. undefined)"
      using h
      by(auto simp: merge_def pair_qbs_Mx_def split_beta' dest: prod_qbs_MxE )
  qed
qed

text ‹ The following lemma corresponds to \cite{Heunen_2017} Proposition 19(1). ›
lemma r_preserves_product':
  "measure_to_qbs (ΠM i∈I. M i) = (ΠQ i∈I. measure_to_qbs (M i))"
proof(rule qbs_eqI)
  show "qbs_Mx (measure_to_qbs (PiM I M)) = qbs_Mx (ΠQ i∈I. measure_to_qbs (M i))"
  proof auto
    fix f
    assume h:"f ∈ real_borel →M PiM I M"
    show "f ∈ prod_qbs_Mx I (λi. measure_to_qbs (M i))"
    proof(rule prod_qbs_MxI)
      fix i
      assume 1:"i ∈ I"
      show "(λr. f r i) ∈ qbs_Mx (measure_to_qbs (M i))"
        using measurable_comp[OF h measurable_component_singleton[OF 1,of M]]
        by (simp add: comp_def)
    next
      fix i
      assume 1:"i ∉ I"
      then show "(λr. f r i) = (λr. undefined)"
        using measurable_space[OF h] 1
        by(auto simp: space_PiM PiE_def extensional_def)
    qed
  next
    fix f
    assume h:"f ∈ prod_qbs_Mx I (λi. measure_to_qbs (M i))"
    show "f ∈ real_borel →M PiM I M"
      apply(rule measurable_PiM_single')
      using prod_qbs_MxE(1)[OF h] apply auto[1]
      using PiQ_f[of I M] h by auto
  qed
qed

text ‹ $\prod_{i = 0,1} X_i \cong X_1 \times X_2$. ›
lemma product_binary_product:
 "∃f g. f ∈ (ΠQ i∈UNIV. if i then X else Y) →Q X ⨂Q Y ∧ g ∈ X ⨂Q Y →Q (ΠQ i∈UNIV. if i then X else Y) ∧
        g ∘ f = id ∧ f ∘ g = id"
  by(auto intro!: exI[where x="λf. (f True, f False)"] exI[where x="λxy b. if b then fst xy else snd xy"] qbs_morphismI
            simp: prod_qbs_Mx_def pair_qbs_Mx_def comp_def all_bool_eq ext)

end
>

Theory Binary_CoProduct_QuasiBorel

(*  Title:   Binary_CoProduct_QuasiBorel.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsection ‹Coproduct Spaces›

theory Binary_CoProduct_QuasiBorel
  imports "Measure_QuasiBorel_Adjunction"
begin

subsubsection ‹ Binary Coproduct Spaces  ›
definition copair_qbs_Mx :: "['a quasi_borel, 'b quasi_borel] ⇒ (real => 'a + 'b) set" where
"copair_qbs_Mx X Y ≡ 
  {g. ∃ S ∈ sets real_borel.
  (S = {}   ⟶ (∃ α1∈ qbs_Mx X. g = (λr. Inl (α1 r)))) ∧
  (S = UNIV ⟶ (∃ α2∈ qbs_Mx Y. g = (λr. Inr (α2 r)))) ∧
  ((S ≠ {} ∧ S ≠ UNIV) ⟶
     (∃ α1∈ qbs_Mx X.
      ∃ α2∈ qbs_Mx Y.
          g = (λr::real. (if (r ∈ S) then Inl (α1 r) else Inr (α2 r)))))}"


definition copair_qbs :: "['a quasi_borel, 'b quasi_borel] ⇒ ('a + 'b) quasi_borel" (infixr "<+>Q" 65) where
"copair_qbs X Y ≡ Abs_quasi_borel (qbs_space X <+> qbs_space Y, copair_qbs_Mx X Y)"


text ‹ The followin is an equivalent definition of @{term copair_qbs_Mx}. ›
definition copair_qbs_Mx2 :: "['a quasi_borel, 'b quasi_borel] ⇒ (real => 'a + 'b) set" where
"copair_qbs_Mx2 X Y ≡ 
  {g. (if qbs_space X = {} ∧ qbs_space Y = {} then False
       else if qbs_space X ≠ {} ∧ qbs_space Y = {} then 
                  (∃α1∈ qbs_Mx X. g = (λr. Inl (α1 r)))
       else if qbs_space X = {} ∧ qbs_space Y ≠ {} then 
                  (∃α2∈ qbs_Mx Y. g = (λr. Inr (α2 r)))
       else 
         (∃S ∈ sets real_borel. ∃α1∈ qbs_Mx X. ∃α2∈ qbs_Mx Y.
          g = (λr::real. (if (r ∈ S) then Inl (α1 r) else Inr (α2 r))))) }"

lemma copair_qbs_Mx_equiv :"copair_qbs_Mx (X :: 'a quasi_borel) (Y :: 'b quasi_borel) = copair_qbs_Mx2 X Y"
proof(auto)
(* ⊆ *)
  fix g :: "real ⇒ 'a + 'b"
  assume "g ∈ copair_qbs_Mx X Y"
  then obtain S where hs:"S∈ sets real_borel ∧ 
  (S = {}   ⟶ (∃ α1∈ qbs_Mx X. g = (λr. Inl (α1 r)))) ∧
  (S = UNIV ⟶ (∃ α2∈ qbs_Mx Y. g = (λr. Inr (α2 r)))) ∧
  ((S ≠ {} ∧ S ≠ UNIV) ⟶
     (∃ α1∈ qbs_Mx X.
      ∃ α2∈ qbs_Mx Y.
          g = (λr::real. (if (r ∈ S) then Inl (α1 r) else Inr (α2 r)))))"
    by (auto simp add: copair_qbs_Mx_def)
  consider "S = {}" | "S = UNIV" | "S ≠ {} ∧ S ≠ UNIV" by auto
  then show "g ∈ copair_qbs_Mx2 X Y"
  proof cases
    assume "S = {}"
    from hs this have "∃ α1∈ qbs_Mx X. g = (λr. Inl (α1 r))" by simp
    then obtain α1 where h1:"α1∈ qbs_Mx X ∧ g = (λr. Inl (α1 r))" by auto
    have "qbs_space X ≠ {}"
      using qbs_empty_equiv h1
      by auto
    then have "(qbs_space X ≠ {} ∧ qbs_space Y = {}) ∨ (qbs_space X ≠ {} ∧ qbs_space Y ≠ {})"
      by simp
    then show "g ∈ copair_qbs_Mx2 X Y"
    proof
      assume "qbs_space X ≠ {} ∧ qbs_space Y = {}"
      then show "g ∈ copair_qbs_Mx2 X Y" 
        by(simp add: copair_qbs_Mx2_def ‹∃ α1∈ qbs_Mx X. g = (λr. Inl (α1 r))›)
    next
      assume "qbs_space X ≠ {} ∧ qbs_space Y ≠ {}"
      then obtain α2 where "α2 ∈ qbs_Mx Y" using qbs_empty_equiv by force
      define S' :: "real set" 
        where "S' ≡ UNIV"
      define g' :: "real ⇒ 'a + 'b"
        where "g' ≡ (λr::real. (if (r ∈ S') then Inl (α1 r) else Inr (α2 r)))"
      from ‹qbs_space X ≠ {} ∧ qbs_space Y ≠ {}› h1 ‹α2 ∈ qbs_Mx Y›
      have "g' ∈ copair_qbs_Mx2 X Y" 
        by(force simp add: S'_def g'_def copair_qbs_Mx2_def)
      moreover have "g = g'"
        using h1 by(simp add: g'_def S'_def)
      ultimately show ?thesis
        by simp
    qed
  next
    assume "S = UNIV"
    from hs this have "∃ α2∈ qbs_Mx Y. g = (λr. Inr (α2 r))" by simp
    then obtain α2 where h2:"α2∈ qbs_Mx Y ∧ g = (λr. Inr (α2 r))" by auto
    have "qbs_space Y ≠ {}"
      using qbs_empty_equiv h2
      by auto
    then have "(qbs_space X = {} ∧ qbs_space Y ≠ {}) ∨ (qbs_space X ≠ {} ∧ qbs_space Y ≠ {})"
      by simp
    then show "g ∈ copair_qbs_Mx2 X Y"
    proof
      assume "qbs_space X = {} ∧ qbs_space Y ≠ {}"
      then show ?thesis
        by(simp add: copair_qbs_Mx2_def ‹∃ α2∈ qbs_Mx Y. g = (λr. Inr (α2 r))›)
    next
      assume "qbs_space X ≠ {} ∧ qbs_space Y ≠ {}"
      then obtain α1 where "α1 ∈ qbs_Mx X" using qbs_empty_equiv by force
      define S' :: "real set"
        where "S' ≡ {}"
      define g' :: "real ⇒ 'a + 'b"
        where "g' ≡ (λr::real. (if (r ∈ S') then Inl (α1 r) else Inr (α2 r)))"
      from ‹qbs_space X ≠ {} ∧ qbs_space Y ≠ {}› h2 ‹α1 ∈ qbs_Mx X›
      have "g' ∈ copair_qbs_Mx2 X Y" 
        by(force simp add: S'_def g'_def copair_qbs_Mx2_def)
      moreover have "g = g'"
        using h2 by(simp add: g'_def S'_def)
      ultimately show ?thesis
        by simp
    qed
  next
    assume "S ≠ {} ∧ S ≠ UNIV"
    then have 
    h: "∃ α1∈ qbs_Mx X.
        ∃ α2∈ qbs_Mx Y.
          g = (λr::real. (if (r ∈ S) then Inl (α1 r) else Inr (α2 r)))"
      using hs by simp
    then have "qbs_space X ≠ {} ∧ qbs_space Y ≠ {}"
      by (metis empty_iff qbs_empty_equiv)
    thus ?thesis
      using hs h by(auto simp add: copair_qbs_Mx2_def)
  qed

(* ⊇ *)
next
  fix g :: "real ⇒ 'a + 'b"
  assume "g ∈ copair_qbs_Mx2 X Y"
  then have
  h: "if qbs_space X = {} ∧ qbs_space Y = {} then False
      else if qbs_space X ≠ {} ∧ qbs_space Y = {} then 
                  (∃α1∈ qbs_Mx X. g = (λr. Inl (α1 r)))
      else if qbs_space X = {} ∧ qbs_space Y ≠ {} then 
                  (∃α2∈ qbs_Mx Y. g = (λr. Inr (α2 r)))
      else 
          (∃S ∈ sets real_borel. ∃α1∈ qbs_Mx X. ∃α2∈ qbs_Mx Y.
           g = (λr::real. (if (r ∈ S) then Inl (α1 r) else Inr (α2 r))))"
    by(simp add: copair_qbs_Mx2_def)
  consider "(qbs_space X = {} ∧ qbs_space Y = {})" |
           "(qbs_space X ≠ {} ∧ qbs_space Y = {})" |
           "(qbs_space X = {} ∧ qbs_space Y ≠ {})" |
           "(qbs_space X ≠ {} ∧ qbs_space Y ≠ {})" by auto
  then show "g ∈ copair_qbs_Mx X Y"
  proof cases
    assume "qbs_space X = {} ∧ qbs_space Y = {}"
    then show ?thesis
      using ‹g ∈ copair_qbs_Mx2 X Y› by(simp add: copair_qbs_Mx2_def)
  next
    assume "qbs_space X ≠ {} ∧ qbs_space Y = {}"
    from h this have "∃α1∈ qbs_Mx X. g = (λr. Inl (α1 r))" by simp
    thus ?thesis
      by(auto simp add: copair_qbs_Mx_def)
  next
    assume "qbs_space X = {} ∧ qbs_space Y ≠ {}"
    from h this have "∃α2∈ qbs_Mx Y. g = (λr. Inr (α2 r))" by simp
    thus ?thesis
      unfolding copair_qbs_Mx_def 
      by(force simp add: copair_qbs_Mx_def)
  next
    assume "qbs_space X ≠ {} ∧ qbs_space Y ≠ {}"
    from h this have 
        "∃S ∈ sets real_borel. ∃α1∈ qbs_Mx X. ∃α2∈ qbs_Mx Y.
           g = (λr::real. (if (r ∈ S) then Inl (α1 r) else Inr (α2 r)))" by simp
    then show ?thesis
    proof(auto simp add: exE)
      fix S
      fix α1
      fix α2
      assume "S ∈ sets real_borel"
             "α1 ∈ qbs_Mx X"
             "α2 ∈ qbs_Mx Y"
             "g = (λr. if r ∈ S then Inl (α1 r)
                                else Inr (α2 r))"
      consider "S = {}" | "S = UNIV" | "S ≠ {} ∧ S ≠ UNIV" by auto
      then show "(λr. if r ∈ S then Inl (α1 r) else Inr (α2 r)) ∈ copair_qbs_Mx X Y"
      proof cases
        assume "S = {}"
        then have [simp]: "(λr. if r ∈ S then Inl (α1 r) else Inr (α2 r)) = (λr. Inr (α2 r))"
          by simp
        have "UNIV ∈ sets real_borel" by simp
        then show ?thesis
          using ‹α2 ∈ qbs_Mx Y› unfolding copair_qbs_Mx_def
          by(auto intro! : bexI[where x=UNIV])
      next
        assume "S = UNIV"
        then have "(λr. if r ∈ S then Inl (α1 r) else Inr (α2 r)) = (λr. Inl (α1 r))"
          by simp
        then show ?thesis
          using ‹α1 ∈ qbs_Mx X› 
          by(auto simp add: copair_qbs_Mx_def)
      next
        assume "S ≠ {} ∧ S ≠ UNIV"
        then show ?thesis
          using ‹S ∈ sets real_borel› ‹α1 ∈ qbs_Mx X› ‹α2 ∈ qbs_Mx Y›
          by(auto simp add: copair_qbs_Mx_def)
      qed  
    qed
  qed
qed


lemma copair_qbs_f[simp]: "copair_qbs_Mx X Y ⊆ UNIV → qbs_space X <+> qbs_space Y"
proof
  fix g
  assume "g ∈ copair_qbs_Mx X Y"
  then obtain S where hs:"S∈ sets real_borel ∧ 
  (S = {}   ⟶ (∃ α1∈ qbs_Mx X. g = (λr. Inl (α1 r)))) ∧
  (S = UNIV ⟶ (∃ α2∈ qbs_Mx Y. g = (λr. Inr (α2 r)))) ∧
  ((S ≠ {} ∧ S ≠ UNIV) ⟶
     (∃ α1∈ qbs_Mx X.
      ∃ α2∈ qbs_Mx Y.
          g = (λr::real. (if (r ∈ S) then Inl (α1 r) else Inr (α2 r)))))"
   by (auto simp add: copair_qbs_Mx_def)
  consider "S = {}" | "S = UNIV" | "S ≠ {} ∧ S ≠ UNIV" by auto
  then show "g ∈ UNIV → qbs_space X <+> qbs_space Y"
  proof cases
    assume "S = {}"
    then show ?thesis
      using hs by auto
  next
    assume "S = UNIV"
    then show ?thesis
      using hs by auto
  next
    assume "S ≠ {} ∧ S ≠ UNIV"
    then have "∃ α1∈ qbs_Mx X. ∃ α2∈ qbs_Mx Y.
          g = (λr::real. (if (r ∈ S) then Inl (α1 r) else Inr (α2 r)))" using hs by simp
    then show ?thesis 
      by(auto simp add: exE)
  qed
qed

lemma copair_qbs_closed1: "qbs_closed1 (copair_qbs_Mx X Y)"
proof(auto simp add: qbs_closed1_def)
  fix g
  fix f
  assume "g ∈ copair_qbs_Mx X Y"
         "f ∈ real_borel →M real_borel"
  then have "g ∈ copair_qbs_Mx2 X Y" using copair_qbs_Mx_equiv by auto
  consider "(qbs_space X = {} ∧ qbs_space Y = {})" |
           "(qbs_space X ≠ {} ∧ qbs_space Y = {})" |
           "(qbs_space X = {} ∧ qbs_space Y ≠ {})" |
           "(qbs_space X ≠ {} ∧ qbs_space Y ≠ {})" by auto
  then have "g ∘ f ∈ copair_qbs_Mx2 X Y"
  proof cases
    assume "qbs_space X = {} ∧ qbs_space Y = {}"
    then show ?thesis
      using ‹g ∈ copair_qbs_Mx2 X Y› qbs_empty_equiv by(simp add: copair_qbs_Mx2_def)
  next
    assume "qbs_space X ≠ {} ∧ qbs_space Y = {}"
    then obtain α1 where h1:"α1∈ qbs_Mx X ∧ g = (λr. Inl (α1 r))"
      using ‹g ∈ copair_qbs_Mx2 X Y› by(auto simp add: copair_qbs_Mx2_def)
    then have "α1 ∘ f ∈ qbs_Mx X" 
      using ‹f ∈ real_borel →M real_borel› by auto
    moreover have "g ∘ f = (λr. Inl ((α1 ∘ f) r))"
      using h1 by auto
    ultimately show ?thesis
      using ‹qbs_space X ≠ {} ∧ qbs_space Y = {}› by(force simp add: copair_qbs_Mx2_def)
  next
    assume "(qbs_space X = {} ∧ qbs_space Y ≠ {})"
    then obtain α2 where h2:"α2∈ qbs_Mx Y ∧ g = (λr. Inr (α2 r))"
      using ‹g ∈ copair_qbs_Mx2 X Y› by(auto simp add: copair_qbs_Mx2_def)
    then have "α2 ∘ f ∈ qbs_Mx Y" 
      using ‹f ∈ real_borel →M real_borel› by auto
    moreover have "g ∘ f = (λr. Inr ((α2 ∘ f) r))"
      using h2 by auto
    ultimately show ?thesis
      using ‹(qbs_space X = {} ∧ qbs_space Y ≠ {})› by(force simp add: copair_qbs_Mx2_def)
  next
    assume "qbs_space X ≠ {} ∧ qbs_space Y ≠ {}"
    then have "∃S ∈ sets real_borel. ∃α1∈ qbs_Mx X. ∃α2∈ qbs_Mx Y.
          g = (λr::real. (if (r ∈ S) then Inl (α1 r) else Inr (α2 r)))"
      using ‹g ∈ copair_qbs_Mx2 X Y› by(simp add: copair_qbs_Mx2_def)
    then show ?thesis
    proof(auto simp add: exE)
      fix S
      fix α1
      fix α2
      assume "S ∈ sets real_borel"
             "α1∈ qbs_Mx X"
             "α2 ∈ qbs_Mx Y"
             "g = (λr. if r ∈ S then Inl (α1 r) else Inr (α2 r))"
      have "f -` S ∈ sets real_borel"
        using ‹f ∈ real_borel →M real_borel› ‹S ∈ sets real_borel›
        by (simp add: measurable_sets_borel)
      moreover have "α1 ∘ f ∈ qbs_Mx X"
        using ‹α1∈ qbs_Mx X› ‹f ∈ real_borel →M real_borel› qbs_decomp
        by(auto simp add: qbs_closed1_def)
      moreover have "α2 ∘ f ∈ qbs_Mx Y"
        using ‹α2∈ qbs_Mx Y› ‹f ∈ real_borel →M real_borel› qbs_decomp
        by(auto simp add: qbs_closed1_def)
      moreover have 
        "(λr. if r ∈ S then Inl (α1 r) else Inr (α2 r)) ∘ f = (λr. if r ∈ f -` S then Inl ((α1 ∘ f) r) else Inr ((α2 ∘ f) r))"
        by auto
      ultimately show "(λr. if r ∈ S then Inl (α1 r)  else Inr (α2 r)) ∘ f ∈ copair_qbs_Mx2 X Y"
        using ‹qbs_space X ≠ {} ∧ qbs_space Y ≠ {}› by(force simp add: copair_qbs_Mx2_def)
    qed
  qed
  thus "g ∘ f ∈ copair_qbs_Mx X Y"
    using copair_qbs_Mx_equiv by auto
qed

lemma copair_qbs_closed2: "qbs_closed2 (qbs_space X <+> qbs_space Y) (copair_qbs_Mx X Y)"
proof(auto simp add: qbs_closed2_def)
  fix x
  assume "x ∈ qbs_space X"
  define α1 :: "real ⇒ _" where "α1 ≡ (λr. x)"
  have "α1 ∈ qbs_Mx X" using ‹x ∈ qbs_space X› qbs_decomp 
    by(force simp add: qbs_closed2_def α1_def )
  moreover have "(λr. Inl x) = (λl. Inl (α1 l))" by (simp add: α1_def)
  moreover have "{} ∈ sets real_borel" by auto
  ultimately show "(λr. Inl x) ∈ copair_qbs_Mx X Y"
    by(auto simp add: copair_qbs_Mx_def)
next
  fix y
  assume "y ∈ qbs_space Y"
  define α2 :: "real ⇒ _" where "α2 ≡ (λr. y)"
  have "α2 ∈ qbs_Mx Y" using ‹y ∈ qbs_space Y› qbs_decomp 
    by(force simp add: qbs_closed2_def α2_def )
  moreover have "(λr. Inr y) = (λl. Inr (α2 l))" by (simp add: α2_def)
  moreover have "UNIV ∈ sets real_borel" by auto
  ultimately show "(λr. Inr y) ∈ copair_qbs_Mx X Y"
    unfolding copair_qbs_Mx_def
    by(auto intro!: bexI[where x=UNIV])
qed

lemma copair_qbs_closed3: "qbs_closed3 (copair_qbs_Mx X Y)"
proof(auto simp add: qbs_closed3_def)
  fix P :: "real ⇒ nat"
  fix Fi :: "nat ⇒ real ⇒_ + _"
  assume "∀i. P -` {i} ∈ sets real_borel"
         "∀i. Fi i ∈ copair_qbs_Mx X Y"
  then have "∀i. Fi i ∈ copair_qbs_Mx2 X Y" using copair_qbs_Mx_equiv by blast
  consider "(qbs_space X = {} ∧ qbs_space Y = {})" |
           "(qbs_space X ≠ {} ∧ qbs_space Y = {})" |
           "(qbs_space X = {} ∧ qbs_space Y ≠ {})" |
           "(qbs_space X ≠ {} ∧ qbs_space Y ≠ {})" by auto
  then have "(λr. Fi (P r) r) ∈ copair_qbs_Mx2 X Y"
  proof cases
    assume "qbs_space X = {} ∧ qbs_space Y = {}"
    then show ?thesis
      using ‹∀i. Fi i ∈ copair_qbs_Mx2 X Y› qbs_empty_equiv 
      by(simp add: copair_qbs_Mx2_def)
  next
    assume "qbs_space X ≠ {} ∧ qbs_space Y = {}"
    then have "∀i. ∃αi. αi ∈ qbs_Mx X ∧ Fi i = (λr. Inl (αi r))"
      using ‹∀i. Fi i ∈ copair_qbs_Mx2 X Y› by(auto simp add: copair_qbs_Mx2_def)
    then have "∃α1. ∀i. α1 i ∈ qbs_Mx X ∧ Fi i = (λr. Inl (α1 i r))"
      by(rule choice)
    then obtain α1 :: "nat ⇒ real ⇒ _" 
      where h1: "∀i. α1 i ∈ qbs_Mx X ∧ Fi i = (λr. Inl (α1 i r))" by auto
    define β :: "real ⇒ _" 
      where "β ≡ (λr. α1 (P r) r)"
    from ‹∀i. P -` {i} ∈ sets real_borel› h1
    have "β ∈ qbs_Mx X"
      by (simp add: β_def)
    moreover have "(λr. Fi (P r) r) = (λr. Inl (β r))"
      using h1 by(simp add: β_def)
    ultimately show ?thesis
      using ‹qbs_space X ≠ {} ∧ qbs_space Y = {}› by (auto simp add: copair_qbs_Mx2_def)
  next
    assume "qbs_space X = {} ∧ qbs_space Y ≠ {}"
    then have "∀i. ∃αi. αi ∈ qbs_Mx Y ∧ Fi i = (λr. Inr (αi r))"
      using ‹∀i. Fi i ∈ copair_qbs_Mx2 X Y› by(auto simp add: copair_qbs_Mx2_def)
    then have "∃α2. ∀i. α2 i ∈ qbs_Mx Y ∧ Fi i = (λr. Inr (α2 i r))"
      by(rule choice)
    then obtain α2 :: "nat ⇒ real ⇒ _" 
      where h2: "∀i. α2 i ∈ qbs_Mx Y ∧ Fi i = (λr. Inr (α2 i r))" by auto
    define β :: "real ⇒ _" 
      where "β ≡ (λr. α2 (P r) r)"
    from ‹∀i. P -` {i} ∈ sets real_borel› h2 qbs_decomp
    have "β ∈ qbs_Mx Y"
      by(simp add: β_def)
    moreover have "(λr. Fi (P r) r) = (λr. Inr (β r))"
      using h2 by(simp add: β_def)
    ultimately show ?thesis
      using ‹qbs_space X = {} ∧ qbs_space Y ≠ {}› by (auto simp add: copair_qbs_Mx2_def)
  next
    assume "qbs_space X ≠ {} ∧ qbs_space Y ≠ {}"
    then have "∀i. ∃Si. Si ∈ sets real_borel ∧ (∃α1i∈ qbs_Mx X. ∃α2i∈ qbs_Mx Y.
                   Fi i = (λr::real. (if (r ∈ Si) then Inl (α1i r) else Inr (α2i r))))"
      using ‹∀i. Fi i ∈ copair_qbs_Mx2 X Y› by (auto simp add: copair_qbs_Mx2_def)
    then have "∃S. ∀i. S i ∈ sets real_borel ∧ (∃α1i∈ qbs_Mx X. ∃α2i∈ qbs_Mx Y.
                   Fi i = (λr::real. (if (r ∈ S i) then Inl (α1i r) else Inr (α2i r))))"
      by(rule choice)
    then obtain S :: "nat ⇒ real set" 
      where hs :"∀i. S i ∈ sets real_borel ∧ (∃α1i∈ qbs_Mx X. ∃α2i∈ qbs_Mx Y.
                   Fi i = (λr::real. (if (r ∈ S i) then Inl (α1i r) else Inr (α2i r))))"
      by auto
    then have "∀i. ∃α1i. α1i ∈ qbs_Mx X ∧ (∃α2i∈ qbs_Mx Y.
               Fi i = (λr::real. (if (r ∈ S i) then Inl (α1i r) else Inr (α2i r))))"
      by blast
    then have "∃α1. ∀i. α1 i ∈ qbs_Mx X ∧ (∃α2i∈ qbs_Mx Y.
               Fi i = (λr::real. (if (r ∈ S i) then Inl (α1 i r) else Inr (α2i r))))"
      by(rule choice)
    then obtain α1 
      where h1: "∀i. α1 i ∈ qbs_Mx X ∧ (∃α2i∈ qbs_Mx Y.
               Fi i = (λr::real. (if (r ∈ S i) then Inl (α1 i r) else Inr (α2i r))))"
      by auto
    define β1 :: "real ⇒ _" 
      where "β1 ≡ (λr. α1 (P r) r)"
    from ‹∀i. P -` {i} ∈ sets real_borel› h1 qbs_decomp
    have "β1 ∈ qbs_Mx X"
      by(simp add: β1_def)
    from h1 have "∀i. ∃α2i. α2i∈ qbs_Mx Y ∧
               Fi i = (λr::real. (if (r ∈ S i) then Inl (α1 i r) else Inr (α2i r)))"
      by auto
    then have "∃α2. ∀i. α2 i∈ qbs_Mx Y ∧
               Fi i = (λr::real. (if (r ∈ S i) then Inl (α1 i r) else Inr (α2 i r)))"
      by(rule choice)
    then obtain α2 
      where h2: "∀i. α2 i∈ qbs_Mx Y ∧
               Fi i = (λr::real. (if (r ∈ S i) then Inl (α1 i r) else Inr (α2 i r)))"
      by auto
    define β2 :: "real ⇒ _" 
      where "β2 ≡ (λr. α2 (P r) r)"
    from ‹∀i. P -` {i} ∈ sets real_borel› h2 qbs_decomp
    have "β2 ∈ qbs_Mx Y"
      by(simp add: β2_def)
    define A :: "nat ⇒ real set"
      where "A ≡ (λi. S i ∩ P -` {i})"
    have "∀i. A i ∈ sets real_borel"
      using A_def ‹∀i. P -` {i} ∈ sets real_borel› hs by blast
    define S' :: "real set"
      where "S' ≡ {r. r ∈ S (P r)}"
    have "S' = (⋃i::nat. A i)"
      by(auto simp add: S'_def A_def)
    hence "S' ∈ sets real_borel"
      using ‹∀i. A i ∈ sets real_borel› by auto
    from h2 have "(λr. Fi (P r) r) = (λr. (if r ∈ S' then Inl (β1  r)
                                                      else Inr (β2 r)))"
      by(auto simp add: β1_def β2_def S'_def)
    thus "(λr. Fi (P r) r) ∈ copair_qbs_Mx2 X Y"
      using ‹qbs_space X ≠ {} ∧ qbs_space Y ≠ {}› ‹S' ∈ sets real_borel› ‹β1 ∈ qbs_Mx X› ‹β2 ∈ qbs_Mx Y›
      by(auto simp add: copair_qbs_Mx2_def)
  qed
  thus "(λr. Fi (P r) r) ∈ copair_qbs_Mx X Y"
    using copair_qbs_Mx_equiv by auto
qed

lemma copair_qbs_correct: "Rep_quasi_borel (copair_qbs X Y) = (qbs_space X <+> qbs_space Y, copair_qbs_Mx X Y)"
  unfolding copair_qbs_def
  by(auto intro!: Abs_quasi_borel_inverse copair_qbs_f simp: copair_qbs_closed2 copair_qbs_closed1 copair_qbs_closed3)

lemma copair_qbs_space[simp]: "qbs_space (copair_qbs X Y) = qbs_space X <+> qbs_space Y"
  by(simp add: qbs_space_def copair_qbs_correct)

lemma copair_qbs_Mx[simp]: "qbs_Mx (copair_qbs X Y) = copair_qbs_Mx X Y"
  by(simp add: qbs_Mx_def copair_qbs_correct)


lemma Inl_qbs_morphism:
  "Inl ∈ X →Q X <+>Q Y"
proof(rule qbs_morphismI)
  fix α
  assume "α ∈ qbs_Mx X"
  moreover have "Inl ∘ α = (λr. Inl (α r))" by auto
  ultimately show "Inl ∘ α ∈ qbs_Mx (X <+>Q Y)"
    by(auto simp add: copair_qbs_Mx_def)
qed

lemma Inr_qbs_morphism:
  "Inr ∈ Y →Q X <+>Q Y"
proof(rule qbs_morphismI)
  fix α
  assume "α ∈ qbs_Mx Y"
  moreover have "Inr ∘ α = (λr. Inr (α r))" by auto
  ultimately show "Inr ∘ α ∈ qbs_Mx (X <+>Q Y)"
    by(auto intro!: bexI[where x=UNIV] simp add: copair_qbs_Mx_def)
qed

lemma case_sum_preserves_morphisms:
  assumes "f ∈ X →Q Z"
      and "g ∈ Y →Q Z"
    shows "case_sum f g ∈ X <+>Q Y →Q Z"
proof(rule qbs_morphismI;auto)
  fix α
  assume "α ∈ copair_qbs_Mx X Y"
  then obtain S where hs:"S∈ sets real_borel ∧ 
  (S = {}   ⟶ (∃ α1∈ qbs_Mx X. α = (λr. Inl (α1 r)))) ∧
  (S = UNIV ⟶ (∃ α2∈ qbs_Mx Y. α = (λr. Inr (α2 r)))) ∧
  ((S ≠ {} ∧ S ≠ UNIV) ⟶
     (∃ α1∈ qbs_Mx X.
      ∃ α2∈ qbs_Mx Y.
          α = (λr::real. (if (r ∈ S) then Inl (α1 r) else Inr (α2 r)))))"
    by (auto simp add: copair_qbs_Mx_def)
  consider "S = {}" | "S = UNIV" | "S ≠ {} ∧ S ≠ UNIV" by auto
  then show "case_sum f g ∘ α ∈ qbs_Mx Z"
  proof cases
    assume "S = {}"
    then obtain α1 where h1: "α1∈ qbs_Mx X ∧ α = (λr. Inl (α1 r))"
      using hs by auto
    then have "f ∘ α1 ∈ qbs_Mx Z"
      using assms by(auto simp add: qbs_morphism_def)
    moreover have "case_sum f g ∘ α = f ∘ α1"
      using h1 by auto
    ultimately show ?thesis by simp
  next
    assume "S = UNIV"
    then obtain α2 where h2: "α2∈ qbs_Mx Y ∧ α = (λr. Inr (α2 r))"
      using hs by auto
    then have "g ∘ α2 ∈ qbs_Mx Z"
      using assms by(auto simp add: qbs_morphism_def)
    moreover have "case_sum f g ∘ α = g ∘ α2"
      using h2 by auto
    ultimately show ?thesis by simp
  next
    assume "S ≠ {} ∧ S ≠ UNIV"
    then obtain α1 α2 where h: "α1∈ qbs_Mx X ∧ α2∈ qbs_Mx Y ∧
         α = (λr::real. (if (r ∈ S) then Inl (α1 r) else Inr (α2 r)))"
      using hs by auto
    define F :: "nat ⇒ real ⇒ _"
      where "F ≡ (λi r. (if i = 0 then (f ∘ α1) r
                                    else (g ∘ α2) r))"
    define P :: "real ⇒ nat"
      where "P ≡ (λr. if r ∈ S then 0 else 1)"
    have "f ∘ α1 ∈ qbs_Mx Z"
      using assms h by(simp add: qbs_morphism_def)
    have "g ∘ α2 ∈ qbs_Mx Z"
      using assms h by(simp add: qbs_morphism_def)
    have "∀i. F i ∈ qbs_Mx Z"
    proof(auto simp add: F_def)
      fix i :: nat
      consider "i = 0" | "i ≠ 0" by auto
      then show "(λr. if i = 0 then (f ∘ α1) r else (g ∘ α2) r) ∈ qbs_Mx Z"
      proof cases
        assume "i = 0"
        then have "(λr. if i = 0 then (f ∘ α1) r else (g ∘ α2) r) = f ∘ α1" by auto
        then show ?thesis
          using ‹f ∘ α1 ∈ qbs_Mx Z› by simp
      next
        assume "i ≠ 0"
        then have "(λr. if i = 0 then (f ∘ α1) r else (g ∘ α2) r) = g ∘ α2" by auto
        then show ?thesis
          using ‹g ∘ α2 ∈ qbs_Mx Z› by simp
      qed
    qed
    moreover have "∀i. P -`{i} ∈ sets real_borel"
    proof
      fix i :: nat
      consider "i = 0" | "i = 1" | "i ≠ 0 ∧ i ≠ 1" by auto
      then show "P -`{i} ∈ sets real_borel"
      proof cases
        assume "i = 0"
        then show ?thesis
          using hs by(simp add: P_def)
      next
        assume "i = 1"
        then show ?thesis
          using hs by (simp add: P_def borel_comp)
      next
        assume "i ≠ 0 ∧ i ≠ 1"
        then show ?thesis by(simp add: P_def)
      qed
    qed
    ultimately have "(λr. F (P r) r) ∈ qbs_Mx Z"
      by simp
    moreover have "case_sum f g ∘ α = (λr. F (P r) r)"
      using h by(auto simp add: F_def P_def)
    ultimately show "case_sum f g ∘ α ∈ qbs_Mx Z" by simp
  qed
qed


lemma map_sum_preserves_morphisms:
  assumes "f ∈ X  →Q Y"
      and "g ∈ X' →Q Y'"
    shows "map_sum f g ∈ X <+>Q X' →Q Y <+>Q Y'"
proof(rule qbs_morphismI,simp)
  fix α
  assume "α ∈ copair_qbs_Mx X X'"
  then obtain S where hs:"S∈ sets real_borel ∧ 
  (S = {}   ⟶ (∃ α1∈ qbs_Mx X. α = (λr. Inl (α1 r)))) ∧
  (S = UNIV ⟶ (∃ α2∈ qbs_Mx X'. α = (λr. Inr (α2 r)))) ∧
  ((S ≠ {} ∧ S ≠ UNIV) ⟶
     (∃ α1∈ qbs_Mx X.
      ∃ α2∈ qbs_Mx X'.
          α = (λr::real. (if (r ∈ S) then Inl (α1 r) else Inr (α2 r)))))"
    by (auto simp add: copair_qbs_Mx_def)
  consider "S = {}" | "S = UNIV" | "S ≠ {} ∧ S ≠ UNIV" by auto
  then show "map_sum f g ∘ α ∈ copair_qbs_Mx Y Y'"
  proof cases
    assume "S = {}"
    then obtain α1 where h1: "α1∈ qbs_Mx X ∧ α = (λr. Inl (α1 r))"
      using hs by auto
    define f' :: "real ⇒ _" where "f' ≡ f ∘ α1"
    then have "f' ∈ qbs_Mx Y"
      using assms h1 by(simp add: qbs_morphism_def)
    moreover have "map_sum f g ∘ α = (λr. Inl (f' r))"
      using h1 by (auto simp add: f'_def)
    moreover have "{} ∈ sets real_borel" by simp
    ultimately show ?thesis
      by(auto simp add: copair_qbs_Mx_def)
  next
    assume "S = UNIV"
    then obtain α2 where h2: "α2∈ qbs_Mx X' ∧ α = (λr. Inr (α2 r))"
      using hs by auto
    define g' :: "real ⇒ _" where "g' ≡ g ∘ α2"
    then have "g' ∈ qbs_Mx Y'"
      using assms h2 by(simp add: qbs_morphism_def)
    moreover have "map_sum f g ∘ α = (λr. Inr (g' r))"
      using h2 by (auto simp add: g'_def)
    ultimately show ?thesis
      by(auto intro!: bexI[where x=UNIV] simp add: copair_qbs_Mx_def)
  next
    assume "S ≠ {} ∧ S ≠ UNIV"
    then obtain α1 α2 where h: "α1∈ qbs_Mx X ∧ α2∈ qbs_Mx X' ∧
         α = (λr::real. (if (r ∈ S) then Inl (α1 r) else Inr (α2 r)))"
      using hs by auto
    define f' :: "real ⇒ _" where "f' ≡ f ∘ α1"
    define g' :: "real ⇒ _" where "g' ≡ g ∘ α2"
    have "f' ∈ qbs_Mx Y"
      using assms h by(auto simp: f'_def)
    moreover have "g' ∈ qbs_Mx Y'"
      using assms h by(auto simp: g'_def)
    moreover have "map_sum f g ∘ α = (λr::real. (if (r ∈ S) then Inl (f' r) else Inr (g' r)))"
      using h by(auto simp add: f'_def g'_def)
    moreover have "S ∈ sets real_borel" using hs by simp
    ultimately show ?thesis
      using ‹S ≠ {} ∧ S ≠ UNIV› by(auto simp add: copair_qbs_Mx_def)
  qed
qed


end
d>

Theory CoProduct_QuasiBorel

(*  Title:   CoProduct_QuasiBorel.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsubsection ‹ Countable Coproduct Spaces ›
theory CoProduct_QuasiBorel

imports
 "Product_QuasiBorel"
 "Binary_CoProduct_QuasiBorel"
begin

definition coprod_qbs_Mx :: "['a set, 'a ⇒ 'b quasi_borel] ⇒ (real ⇒ 'a × 'b) set" where
"coprod_qbs_Mx I X ≡ { λr. (f r, α (f r) r) |f α. f ∈ real_borel →M count_space I ∧ (∀i∈range f. α i ∈ qbs_Mx (X i))}"

lemma coprod_qbs_MxI:
  assumes "f ∈ real_borel →M count_space I"
      and "⋀i. i ∈ range f ⟹ α i ∈ qbs_Mx (X i)"
    shows "(λr. (f r, α (f r) r)) ∈ coprod_qbs_Mx I X"
  using assms unfolding coprod_qbs_Mx_def by blast

definition coprod_qbs_Mx' :: "['a set, 'a ⇒ 'b quasi_borel] ⇒ (real ⇒ 'a × 'b) set" where
"coprod_qbs_Mx' I X ≡ { λr. (f r, α (f r) r) |f α. f ∈ real_borel →M count_space I ∧ (∀i. (i ∈ range f ∨ qbs_space (X i) ≠ {}) ⟶ α i ∈ qbs_Mx (X i))}"

lemma coproduct_qbs_Mx_eq:
 "coprod_qbs_Mx I X = coprod_qbs_Mx' I X"
proof auto
  fix α
  assume "α  ∈ coprod_qbs_Mx I X"
  then obtain f β where hfb:
    "f ∈ real_borel →M count_space I"
    "⋀i. i ∈ range f ⟹ β i ∈ qbs_Mx (X i)" "α = (λr. (f r, β (f r) r))"
    unfolding coprod_qbs_Mx_def by blast
  define β' where "β' ≡ (λi. if i ∈ range f then β i
                              else if qbs_space (X i) ≠ {} then (SOME γ. γ ∈ qbs_Mx (X i))
                              else β i)"
  have 1:"α = (λr. (f r, β' (f r) r))"
    by(simp add: hfb(3) β'_def)
  have 2:"⋀i. qbs_space (X i) ≠ {} ⟹ β' i ∈ qbs_Mx (X i)"
  proof -
    fix i
    assume hne:"qbs_space (X i) ≠ {}"
    then obtain x where "x ∈ qbs_space (X i)" by auto
    hence "(λr. x) ∈ qbs_Mx (X i)" by auto
    thus "β' i ∈ qbs_Mx (X i)"
      by(cases "i ∈ range f") (auto simp: β'_def hfb(2) hne intro!: someI2[where a="λr. x"])
  qed
  show "α ∈ coprod_qbs_Mx' I X"
    using hfb(1,2) 1 2 by(auto simp: coprod_qbs_Mx'_def intro!: exI[where x=f] exI[where x=β'])
next
  fix α
  assume "α ∈ coprod_qbs_Mx' I X"
  then obtain f β where hfb:
    "f ∈ real_borel →M count_space I"  "⋀i. qbs_space (X i) ≠ {} ⟹ β i ∈ qbs_Mx (X i)"
    "⋀i. i ∈ range f ⟹ β i ∈ qbs_Mx (X i)"  "α = (λr. (f r, β (f r) r))"
    unfolding coprod_qbs_Mx'_def by blast
  show "α ∈ coprod_qbs_Mx I X"
    by(auto simp: hfb(4) intro!: coprod_qbs_MxI[OF hfb(1) hfb(3)])
qed

definition coprod_qbs :: "['a set, 'a ⇒ 'b quasi_borel] ⇒ ('a × 'b) quasi_borel" where
"coprod_qbs I X ≡ Abs_quasi_borel (SIGMA i:I. qbs_space (X i), coprod_qbs_Mx I X)"

syntax
 "_coprod_qbs" :: "pttrn ⇒ 'i set ⇒ 'a quasi_borel ⇒ ('i × 'a) quasi_borel" ("(3⨿Q _∈_./ _)"  10)
translations
 "⨿Q x∈I. M" ⇌ "CONST coprod_qbs I (λx. M)"

lemma coprod_qbs_f[simp]: "coprod_qbs_Mx I X ⊆ UNIV → (SIGMA i:I. qbs_space (X i))"
  by(fastforce simp: coprod_qbs_Mx_def dest: measurable_space)

lemma coprod_qbs_closed1: "qbs_closed1 (coprod_qbs_Mx I X)"
proof(rule qbs_closed1I)
  fix α f
  assume "α ∈ coprod_qbs_Mx I X"
    and 1[measurable]: "f ∈ real_borel →M real_borel"
  then obtain β g where ha:
   "⋀i. i ∈ range g ⟹ β i ∈ qbs_Mx (X i)" "α = (λr. (g r, β (g r) r))" and [measurable]:"g ∈ real_borel →M count_space I"
    by(fastforce simp: coprod_qbs_Mx_def)
  then have "⋀i. i ∈ range g ⟹ β i ∘ f ∈ qbs_Mx (X i)"
    by simp
  thus "α ∘ f ∈ coprod_qbs_Mx I X"
    by(auto intro!: coprod_qbs_MxI[where f="g ∘ f" and α="λi. β i ∘ f",simplified comp_def] simp: ha(2) comp_def)
qed

lemma coprod_qbs_closed2: "qbs_closed2 (SIGMA i:I. qbs_space (X i)) (coprod_qbs_Mx I X)"
proof(rule qbs_closed2I,auto)
  fix i x
  assume "i ∈ I" "x ∈ qbs_space (X i)"
  then show "(λr. (i,x)) ∈ coprod_qbs_Mx I X"
    by(auto simp: coprod_qbs_Mx_def intro!: exI[where x="λr. i"])
qed

lemma coprod_qbs_closed3:
 "qbs_closed3 (coprod_qbs_Mx I X)"
proof(rule qbs_closed3I)
  fix P Fi
  assume h:"⋀i :: nat. P -` {i} ∈ sets real_borel"
           "⋀i :: nat. Fi i ∈ coprod_qbs_Mx I X"
  then have "∀i. ∃fi αi. Fi i = (λr. (fi r, αi (fi r) r)) ∧ fi ∈ real_borel →M count_space I ∧ (∀j. (j ∈ range fi ∨ qbs_space (X j) ≠ {}) ⟶ αi j ∈ qbs_Mx (X j))"
    by(auto simp: coproduct_qbs_Mx_eq coprod_qbs_Mx'_def)
  then obtain fi where
   "∀i. ∃αi. Fi i = (λr. (fi i r, αi (fi i r) r)) ∧ fi i ∈ real_borel →M count_space I ∧ (∀j. (j ∈ range (fi i) ∨ qbs_space (X j) ≠ {}) ⟶ αi j ∈ qbs_Mx (X j))"
    by(fastforce intro!: choice)
  then obtain αi where
  "∀i. Fi i = (λr. (fi i r, αi i (fi i r) r)) ∧ fi i ∈ real_borel →M count_space I ∧ (∀j. (j ∈ range (fi i) ∨ qbs_space (X j) ≠ {}) ⟶ αi i j ∈ qbs_Mx (X j))"
    by(fastforce intro!: choice)
  then have hf:
   "⋀i. Fi i = (λr. (fi i r, αi i (fi i r) r))" "⋀i. fi i ∈ real_borel →M count_space I" "⋀i j. j ∈ range (fi i) ⟹ αi i j ∈ qbs_Mx (X j)" "⋀i j. qbs_space (X j) ≠ {} ⟹ αi i j ∈ qbs_Mx (X j)"
    by auto

  define f' where "f' ≡ (λr. fi (P r) r)"
  define α' where "α' ≡ (λi r. αi (P r) i r)"
  have 1:"(λr. Fi (P r) r) = (λr. (f' r, α' (f' r) r))"
    by(simp add: α'_def f'_def hf)
  have "f' ∈ real_borel →M count_space I"
  proof -
    note [measurable] = separate_measurable[OF h(1)]
    have "(λ(n,r). fi n r) ∈ count_space UNIV ⨂M real_borel →M count_space I"
      by(auto intro!: measurable_pair_measure_countable1 simp: hf)
    hence [measurable]:"(λ(n,r). fi n r) ∈ nat_borel ⨂M real_borel →M count_space I"
      using measurable_cong_sets[OF sets_pair_measure_cong[OF sets_borel_eq_count_space],of real_borel real_borel]
      by auto
    thus ?thesis
      using measurable_comp[of "λr. (P r, r)" _ _ "(λ(n,r). fi n r)"]
      by(simp add: f'_def)
  qed
  moreover have "⋀i. i ∈ range f' ⟹ α' i ∈ qbs_Mx (X i)"
  proof -
    fix i
    assume hi:"i ∈ range f'"
    then obtain r where hr:
     "i = fi (P r) r" by(auto simp: f'_def)
    hence "i ∈ range (fi (P r))" by simp
    hence "αi (P r) i ∈ qbs_Mx (X i)" by(simp add: hf)
    hence "qbs_space (X i) ≠ {}"
      by(auto simp: qbs_empty_equiv)
    hence "⋀j. αi j i ∈ qbs_Mx (X i)"
      by(simp add: hf(4))
    then show "α' i ∈ qbs_Mx (X i)"
      by(auto simp: α'_def h(1) intro!: qbs_closed3_dest[of P "λj. αi j i"])
  qed
  ultimately show "(λr. Fi (P r) r) ∈ coprod_qbs_Mx I X"
    by(auto intro!: coprod_qbs_MxI simp: 1)
qed

lemma coprod_qbs_correct: "Rep_quasi_borel (coprod_qbs I X) = (SIGMA i:I. qbs_space (X i), coprod_qbs_Mx I X)"
  unfolding coprod_qbs_def
  using is_quasi_borel_intro[OF coprod_qbs_f coprod_qbs_closed1 coprod_qbs_closed2 coprod_qbs_closed3]
  by(fastforce intro!: Abs_quasi_borel_inverse)

lemma coproduct_qbs_space[simp]: "qbs_space (coprod_qbs I X) = (SIGMA i:I. qbs_space (X i))"
  by(simp add: coprod_qbs_correct qbs_space_def)

lemma coproduct_qbs_Mx[simp]: "qbs_Mx (coprod_qbs I X) = coprod_qbs_Mx I X"
  by(simp add: coprod_qbs_correct qbs_Mx_def)


lemma ini_morphism:
  assumes "j ∈ I"
  shows "(λx. (j,x)) ∈ X j →Q (⨿Q i∈I. X i)"
  by(fastforce intro!: qbs_morphismI exI[where x="λr. j"] simp: coprod_qbs_Mx_def comp_def assms)

lemma coprod_qbs_canonical1:
  assumes "countable I"
      and "⋀i. i ∈ I ⟹ f i ∈ X i →Q Y"
    shows  "(λ(i,x). f i x) ∈ (⨿Q i ∈I. X i) →Q Y"
proof(rule qbs_morphismI)
  fix α
  assume "α ∈ qbs_Mx (coprod_qbs I X)"
  then obtain β g where ha:
   "⋀i. i ∈ range g ⟹ β i ∈ qbs_Mx (X i)" "α = (λr. (g r, β (g r) r))" and hg[measurable]:"g ∈ real_borel →M count_space I"
    by(fastforce simp: coprod_qbs_Mx_def)
  define f' where "f' ≡ (λi r. f i (β i r))"
  have "range g ⊆ I"
    using measurable_space[OF hg] by auto
  hence 1:"(⋀i. i ∈ range g ⟹ f' i ∈ qbs_Mx Y)"
    using qbs_morphismE(3)[OF assms(2) ha(1),simplified comp_def]
    by(auto simp: f'_def)
  have "(λ(i, x). f i x) ∘ α = (λr. f' (g r) r)"
    by(auto simp: ha(2) f'_def)
  also have "... ∈ qbs_Mx Y"
    by(auto intro!: qbs_closed3_dest2'[OF assms(1) hg,of f',OF 1])
  finally show "(λ(i, x). f i x) ∘ α ∈ qbs_Mx Y " .
qed

lemma coprod_qbs_canonical1':
  assumes "countable I"
      and "⋀i. i ∈ I ⟹ (λx. f (i,x)) ∈ X i →Q Y"
    shows  "f ∈ (⨿Q i ∈I. X i) →Q Y"
  using coprod_qbs_canonical1[where f="curry f"] assms by(auto simp: curry_def)


text ‹ $\coprod_{i=0,1} X_i \cong X_1 + X_2$. ›
lemma coproduct_binary_coproduct:
 "∃f g. f ∈ (⨿Q i∈UNIV. if i then X else Y) →Q X <+>Q Y ∧ g ∈ X <+>Q Y →Q (⨿Q i∈UNIV. if i then X else Y) ∧
        g ∘ f = id ∧ f ∘ g = id"
proof(auto intro!: exI[where x="λ(b,z). if b then Inl z else Inr z"] exI[where x="case_sum (λz. (True,z)) (λz. (False,z))"])
  show "(λ(b, z). if b then Inl z else Inr z) ∈ (⨿Q i∈UNIV. if i then X else Y) →Q X <+>Q Y"
  proof(rule qbs_morphismI)
    fix α
    assume " α ∈ qbs_Mx (⨿Q i∈UNIV. if i then X else Y)"
    then obtain f β where hf:
      "α = (λr. (f r, β (f r) r))" "f ∈ real_borel →M count_space UNIV" "⋀i. i ∈ range f ⟹ β i ∈ qbs_Mx (if i then X else Y)"
      by(auto simp: coprod_qbs_Mx_def)
    consider "range f = {True}" | "range f = {False}" | "range f = {True,False}"
      by auto
    thus "(λ(b, z). if b then Inl z else Inr z) ∘ α ∈ qbs_Mx (X <+>Q Y)"
    proof cases
      case 1
      then have "⋀r. f r = True"
        by auto
      then show ?thesis
        using hf(3)
        by(auto intro!: bexI[where x="{}"] bexI[where x="β True"] simp: copair_qbs_Mx_def split_beta' comp_def hf(1))
    next
      case 2
      then have "⋀r. f r = False"
        by auto
      then show ?thesis
        using hf(3)
        by(auto intro!: bexI[where x="UNIV"] bexI[where x="β False"] simp: copair_qbs_Mx_def split_beta' comp_def hf(1))
    next
      case 3
      then have 4:"f -` {True} ∈ sets real_borel"
        using measurable_sets[OF hf(2)] by simp
      have 5:"f -` {True} ≠ {} ∧ f -` {True} ≠ UNIV"
        using 3
        by (metis empty_iff imageE insertCI vimage_singleton_eq)
      have 6:"β True ∈ qbs_Mx X" "β False ∈ qbs_Mx Y"
        using hf(3)[of True] hf(3)[of False] by(auto simp: 3)
      show ?thesis
        apply(simp add: copair_qbs_Mx_def)
        apply(intro bexI[OF _ 4])
        apply(simp add: 5)
        apply(intro bexI[OF _ 6(1)] bexI[OF _ 6(2)])
        apply(auto simp add: hf(1) comp_def)
        done
    qed
  qed
next
  show "case_sum (Pair True) (Pair False) ∈ X <+>Q Y →Q (⨿Q i∈UNIV. if i then X else Y)"
  proof(rule qbs_morphismI)
    fix α
    assume "α ∈ qbs_Mx (X <+>Q Y)"
    then obtain S where hs:
    "S ∈ sets real_borel" "S = {}   ⟶ (∃ α1∈ qbs_Mx X. α = (λr. Inl (α1 r)))" "S = UNIV ⟶ (∃ α2∈ qbs_Mx Y. α = (λr. Inr (α2 r)))"
    "(S ≠ {} ∧ S ≠ UNIV) ⟶ (∃ α1∈ qbs_Mx X. ∃ α2∈ qbs_Mx Y. α = (λr::real. (if (r ∈ S) then Inl (α1 r) else Inr (α2 r))))"
      by(auto simp: copair_qbs_Mx_def)
    consider "S = {}" | "S = UNIV" | "S ≠ {} ∧ S ≠ UNIV" by auto
    thus "case_sum (Pair True) (Pair False) ∘ α  ∈ qbs_Mx (⨿Q i∈UNIV. if i then X else Y)"
    proof cases
      case 1
      then obtain α1 where ha:
      "α1∈ qbs_Mx X" "α = (λr. Inl (α1 r))"
        using hs(2) by auto
      hence "case_sum (Pair True) (Pair False) ∘ α = (λr. (True, α1 r))"
        by auto
      thus ?thesis
        by(auto intro!: coprod_qbs_MxI simp: ha)
    next
      case 2
      then obtain α2 where ha:
      "α2∈ qbs_Mx Y" "α = (λr. Inr (α2 r))"
        using hs(3) by auto
      hence "case_sum (Pair True) (Pair False) ∘ α = (λr. (False, α2 r))"
        by auto
      thus ?thesis
        by(auto intro!: coprod_qbs_MxI simp: ha)
    next
      case 3
      then obtain α1 α2 where ha:
       "α1∈ qbs_Mx X" "α2∈ qbs_Mx Y" "α = (λr. (if (r ∈ S) then Inl (α1 r) else Inr (α2 r)))"
        using hs(4) by auto
      define f :: "real ⇒ bool" where "f ≡ (λr. r ∈ S)"
      define α' where "α' ≡ (λi. if i then α1 else α2)"
      have "case_sum (Pair True) (Pair False) ∘ α = (λr. (f r, α' (f r) r))"
        by(auto simp: f_def α'_def ha(3))
      thus ?thesis
        using hs(1)
        by(auto intro!: coprod_qbs_MxI simp: ha α'_def f_def)
    qed
  qed
next
  show "(λ(b, z). if b then Inl z else Inr z) ∘ case_sum (Pair True) (Pair False) = id"
    by (auto simp add: sum.case_eq_if )
qed


subsubsection ‹ Lists ›
abbreviation "list_of X ≡ ⨿Q n∈(UNIV :: nat set). (ΠQ i∈{..<n}. X)"
abbreviation list_nil :: "nat × (nat ⇒ 'a)" where
"list_nil ≡ (0, λn. undefined)"
abbreviation list_cons :: "['a, nat × (nat ⇒ 'a)] ⇒ nat × (nat ⇒ 'a)" where
"list_cons x l ≡ (Suc (fst l), (λn. if n = 0 then x else (snd l) (n - 1)))"

definition list_head :: "nat × (nat ⇒ 'a) ⇒ 'a" where
"list_head l = snd l 0"
definition list_tail :: "nat × (nat ⇒ 'a) ⇒ nat × (nat ⇒ 'a)" where
"list_tail l = (fst l - 1, λm. (snd l) (Suc m))"


lemma list_simp1:
 "list_nil ≠ list_cons x l"
  by simp

lemma list_simp2:
  assumes "list_cons a al = list_cons b bl"
  shows "a = b" "al = bl"
proof -
  have "a = snd (list_cons a al) 0"
       "b = snd (list_cons b bl) 0"
    by auto
  thus "a = b"
    by(simp add: assms)
next
  have "fst al = fst bl"
    using assms by simp
  moreover have "snd al = snd bl"
  proof
    fix n
    have "snd al n = snd (list_cons a al) (Suc n)"
      by simp
    also have "... = snd (list_cons b bl) (Suc n)"
      by (simp add: assms)
    also have "... = snd bl n"
      by simp
    finally show "snd al n = snd bl n" .
  qed
  ultimately show "al = bl"
    by (simp add: prod.expand)
qed

lemma list_simp3:
  shows "list_head (list_cons a l) = a"
  by(simp add: list_head_def)

lemma list_simp4:
  assumes "l ∈ qbs_space (list_of X)"
  shows "list_tail (list_cons a l) = l"
  using assms by(simp_all add: list_tail_def)

lemma list_decomp1:
  assumes "l ∈ qbs_space (list_of X)"
  shows "l = list_nil ∨
         (∃a l'. a ∈ qbs_space X ∧ l' ∈ qbs_space (list_of X) ∧ l = list_cons a l')"
proof(cases l)
  case hl:(Pair n f)
  show ?thesis
  proof(cases n)
    case 0
    then show ?thesis
      using assms hl by simp
  next
    case hn:(Suc n')
    define f' where "f' ≡ λm. f (Suc m)"
    have "l = list_cons (f 0) (n',f')"
    proof(simp add: hl hn, standard)
      fix m
      show "f m = (if m = 0 then f 0 else snd (n', f') (m - 1))"
        using assms hl by(cases m; fastforce simp: f'_def) 
    qed
    moreover have "(n', f') ∈ qbs_space (list_of X)"
    proof(simp,rule PiE_I)
      show "⋀x. x ∈ {..<n'} ⟹ f' x ∈ qbs_space X"
        using assms hl hn by(fastforce simp: f'_def)
    next
      fix x
      assume 1:"x ∉ {..<n'}"
      thus " f' x = undefined"
        using hl assms hn by(auto simp: f'_def)
    qed
    ultimately show ?thesis
      using hl assms
      by(auto intro!: exI[where x="f 0"] exI[where x="(n',λm. if m = 0 then undefined else f (Suc m))"])
  qed
qed

lemma list_simp5:
  assumes "l ∈ qbs_space (list_of X)"
      and "l ≠ list_nil"
    shows "l = list_cons (list_head l) (list_tail l)"
proof -
  obtain a l' where hl:
  "a ∈ qbs_space X" "l' ∈ qbs_space (list_of X)" "l = list_cons a l'"
    using list_decomp1[OF assms(1)] assms(2) by blast
  hence "list_head l = a" "list_tail l = l'"
    using list_simp3 list_simp4 by auto
  thus ?thesis
    using hl(3) list_simp2 by auto
qed

lemma list_simp6:
 "list_nil ∈ qbs_space (list_of X)"
  by simp

lemma list_simp7:
  assumes "a ∈ qbs_space X"
      and "l ∈ qbs_space (list_of X)"
    shows "list_cons a l ∈ qbs_space (list_of X)"
  using assms by(fastforce simp: PiE_def extensional_def)

lemma list_destruct_rule:
  assumes "l ∈ qbs_space (list_of X)"
          "P list_nil"
      and "⋀a l'. a ∈ qbs_space X ⟹ l' ∈ qbs_space (list_of X) ⟹ P (list_cons a l')"
    shows "P l"
  by(rule disjE[OF list_decomp1[OF assms(1)]]) (use assms in auto)

lemma list_induct_rule:
  assumes "l ∈ qbs_space (list_of X)"
          "P list_nil"
      and "⋀a l'. a ∈ qbs_space X ⟹ l' ∈ qbs_space (list_of X) ⟹ P l' ⟹ P (list_cons a l')"
    shows "P l"
proof(cases l)
  case hl:(Pair n f)
  then show ?thesis
    using assms(1)
  proof(induction n arbitrary: f l)
    case 0
    then show ?case
      using assms(1,2) by simp
  next
    case ih:(Suc n)
    then obtain a l' where hl:
    "a ∈ qbs_space X" "l' ∈ qbs_space (list_of X)" "l = list_cons a l'"
      using list_decomp1 by blast
    have "P l'"
      using ih hl(3)
      by(auto intro!: ih(1)[OF _ hl(2),of "snd l'"])
    from assms(3)[OF hl(1,2) this]
    show ?case
      by(simp add: hl(3))
  qed
qed


fun from_list :: "'a list ⇒ nat × (nat ⇒ 'a)" where
 "from_list [] = list_nil" |
 "from_list (a#l) = list_cons a (from_list l)"

fun to_list' ::  "nat ⇒ (nat ⇒ 'a) ⇒ 'a list" where
 "to_list' 0 _ = []" |
 "to_list' (Suc n) f = f 0 # to_list' n (λn. f (Suc n))"

definition to_list :: "nat × (nat ⇒ 'a) ⇒ 'a list" where
"to_list ≡ case_prod to_list'"

lemma to_list_simp1:
  shows "to_list list_nil = []"
  by(simp add: to_list_def)

lemma to_list_simp2:
  assumes "l ∈ qbs_space (list_of X)"
  shows "to_list (list_cons a l) = a # to_list l"
  using assms by(auto simp:PiE_def to_list_def)

lemma from_list_length:
 "fst (from_list l) = length l"
  by(induction l, simp_all)

lemma from_list_in_list_of:
  assumes "set l ⊆ qbs_space X"
  shows "from_list l ∈ qbs_space (list_of X)"
  using assms by(induction l) (auto simp: PiE_def extensional_def Pi_def)

lemma from_list_in_list_of':
  shows "from_list l ∈ qbs_space (list_of (Abs_quasi_borel (UNIV,UNIV)))"
proof -
  have "set l ⊆ qbs_space (Abs_quasi_borel (UNIV,UNIV))"
    by(simp add: qbs_space_def Abs_quasi_borel_inverse[of "(UNIV,UNIV)",simplified is_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def,simplified])
  thus ?thesis
    using from_list_in_list_of by blast
qed

lemma list_cons_in_list_of:
  assumes "set (a#l) ⊆ qbs_space X"
  shows "list_cons a (from_list l) ∈ qbs_space (list_of X)"
  using from_list_in_list_of[OF assms] by simp

lemma from_list_to_list_ident:
 "(to_list ∘ from_list) l = l"
  by(induction l)
   (simp add: to_list_def,simp add: to_list_simp2[OF from_list_in_list_of'])

lemma to_list_from_list_ident:
  assumes "l ∈ qbs_space (list_of X)"
  shows "(from_list ∘ to_list) l = l"
proof(rule list_induct_rule[OF assms])
  fix a l'
  assume h: "l' ∈ qbs_space (list_of X)"
     and ih:"(from_list ∘ to_list) l' = l'"
  show "(from_list ∘ to_list) (list_cons a l') = list_cons a l'"
    by(auto simp add: to_list_simp2[OF h] ih[simplified])
qed (simp add: to_list_simp1)


definition rec_list' :: "'b ⇒ ('a ⇒ (nat × (nat ⇒ 'a)) ⇒ 'b ⇒ 'b) ⇒ (nat × (nat ⇒ 'a)) ⇒ 'b" where
"rec_list' t0 f l ≡ (rec_list t0 (λx l'. f x (from_list l')) (to_list l))"

lemma rec_list'_simp1:
 "rec_list' t f list_nil = t"
  by(simp add: rec_list'_def to_list_simp1)

lemma rec_list'_simp2:
  assumes "l ∈ qbs_space (list_of X)"
  shows "rec_list' t f (list_cons x l) = f x l (rec_list' t f l)"
  by(simp add: rec_list'_def to_list_simp2[OF assms] to_list_from_list_ident[OF assms,simplified])

end
>

Theory Exponent_QuasiBorel

(*  Title:   Exponent_QuasiBorel.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsection ‹Function Spaces›

theory Exponent_QuasiBorel
  imports "CoProduct_QuasiBorel"
begin

subsubsection ‹ Function Spaces  ›
definition exp_qbs_Mx :: "['a quasi_borel, 'b quasi_borel] ⇒ (real ⇒ 'a => 'b) set" where
"exp_qbs_Mx X Y ≡ {g :: real ⇒ 'a ⇒ 'b. case_prod g ∈ ℝQ ⨂Q X →Q Y} "

definition exp_qbs :: "['a quasi_borel, 'b quasi_borel] ⇒ ('a ⇒ 'b) quasi_borel" (infixr "⇒Q" 61) where
"X ⇒Q Y ≡ Abs_quasi_borel (X →Q Y, exp_qbs_Mx X Y)"


lemma exp_qbs_f[simp]: "exp_qbs_Mx X Y ⊆ UNIV → (X :: 'a quasi_borel) →Q (Y :: 'b quasi_borel)"
proof(auto intro!: qbs_morphismI)
  fix f α r
  assume h:"f ∈ exp_qbs_Mx X Y"
           "α ∈ qbs_Mx X"
  have "f r ∘ α = (λy. case_prod f (r,y)) ∘ α"
    by auto
  also have "... ∈ qbs_Mx Y"
    using qbs_morphism_Pair1'[of r "ℝQ" "case_prod f" X Y] h
    by(auto simp: exp_qbs_Mx_def)
  finally show "f r ∘ α ∈ qbs_Mx Y" .
qed

lemma exp_qbs_closed1: "qbs_closed1 (exp_qbs_Mx X Y)"
proof(rule qbs_closed1I)
  fix a
  fix f
  assume h:"a ∈ exp_qbs_Mx X Y"
           "f ∈ real_borel →M real_borel"
  have "a ∘ f = (λr y. case_prod a (f r,y))" by auto
  moreover have "case_prod ... ∈ ℝQ ⨂Q X →Q Y"
  proof -
    have "case_prod (λr y. case_prod a (f r,y)) = case_prod a ∘ map_prod f id"
      by auto
    also have "... ∈ ℝQ ⨂Q X →Q Y"
      using h
      by(auto intro!: qbs_morphism_comp qbs_morphism_map_prod simp: exp_qbs_Mx_def)
    finally show ?thesis .
  qed
  ultimately show "a ∘ f ∈ exp_qbs_Mx X Y"
    by (simp add: exp_qbs_Mx_def)
qed

lemma exp_qbs_closed2: "qbs_closed2 (X →Q Y) (exp_qbs_Mx X Y)"
  by(auto intro!: qbs_closed2I qbs_morphism_snd'' simp: exp_qbs_Mx_def split_beta')

lemma exp_qbs_closed3:"qbs_closed3 (exp_qbs_Mx X Y)"
proof(rule qbs_closed3I)
  fix P :: "real ⇒ nat"
  fix Fi :: "nat ⇒ real ⇒ _"
  assume h:"⋀i. P -` {i} ∈ sets real_borel"
           "⋀i. Fi i ∈ exp_qbs_Mx X Y"
  show "(λr. Fi (P r) r) ∈ exp_qbs_Mx X Y"
    unfolding exp_qbs_Mx_def
  proof(auto intro!: qbs_morphismI)
    fix α β
    assume h':"α ∈ pair_qbs_Mx ℝQ X "
    have 1:"⋀i. (λ(r,x). Fi i r x) ∘ α ∈ qbs_Mx Y"
      using qbs_morphismE(3)[OF h(2)[simplified exp_qbs_Mx_def,simplified]] h'
      by(simp add: exp_qbs_Mx_def)
    have 2:"⋀i. (P ∘ (λr. fst (α r)))  -` {i} ∈ sets real_borel"
      using separate_measurable[OF h(1)] h'
      by(auto intro!: measurable_separate simp: pair_qbs_Mx_def comp_def)
    show "(λ(r, y). Fi (P r) r y) ∘ α ∈ qbs_Mx Y"
      using qbs_closed3_dest[OF 2,of "λi. (λ(r,x). Fi i r x) ∘ α",OF 1]
      by(simp add: comp_def split_beta')
  qed
qed


lemma exp_qbs_correct: "Rep_quasi_borel (exp_qbs X Y) = (X →Q Y, exp_qbs_Mx X Y)"
  unfolding exp_qbs_def
  by(auto intro!: Abs_quasi_borel_inverse exp_qbs_f simp: exp_qbs_closed1 exp_qbs_closed2 exp_qbs_closed3)

lemma exp_qbs_space[simp]: "qbs_space (exp_qbs X Y) = X →Q Y"
  by(simp add: qbs_space_def exp_qbs_correct)

lemma exp_qbs_Mx[simp]: "qbs_Mx (exp_qbs X Y) = exp_qbs_Mx X Y"
  by(simp add: qbs_Mx_def exp_qbs_correct)


lemma qbs_exp_morphismI:
  assumes "⋀α β. α ∈ qbs_Mx X ⟹
                 β ∈ pair_qbs_Mx real_quasi_borel Y ⟹
                 (λ(r,x). (f ∘ α) r x) ∘ β ∈ qbs_Mx Z"
   shows "f ∈ X →Q exp_qbs Y Z"
  using assms
  by(auto intro!: qbs_morphismI simp: exp_qbs_Mx_def comp_def)

definition qbs_eval :: "(('a ⇒ 'b) × 'a)  ⇒ 'b" where
"qbs_eval a ≡ (fst a) (snd a)"

lemma qbs_eval_morphism:
  "qbs_eval ∈ (exp_qbs X Y) ⨂Q X →Q Y"
proof(rule qbs_morphismI,simp)
  fix f
  assume "f ∈ pair_qbs_Mx (exp_qbs X Y) X"
  let ?f1 = "fst ∘ f"
  let ?f2 = "snd ∘ f"
  define g :: "real ⇒ real × _" 
    where "g ≡ λr.(r,?f2 r)"
  have "g ∈ qbs_Mx (real_quasi_borel ⨂Q X)"
  proof(auto simp add: pair_qbs_Mx_def)
    have "fst ∘ g = id" by(auto simp add: g_def comp_def)
    thus "fst ∘ g ∈ real_borel →M real_borel" by(auto simp add: measurable_ident)
  next
    have "snd ∘ g = ?f2" by(auto simp add: g_def)
    thus "snd ∘ g ∈ qbs_Mx X" 
      using ‹f ∈ pair_qbs_Mx (exp_qbs X Y) X› pair_qbs_Mx_def by auto
  qed
  moreover have "?f1 ∈ exp_qbs_Mx X Y"
    using ‹f ∈ pair_qbs_Mx (exp_qbs X Y) X›
    by(simp add: pair_qbs_Mx_def)
  ultimately have "(λ(r,x). (?f1 r x)) ∘ g ∈ qbs_Mx Y"
    by (auto simp add: exp_qbs_Mx_def qbs_morphism_def)
       (metis (mono_tags, lifting) case_prod_conv comp_apply cond_case_prod_eta)
  moreover have "(λ(r,x). (?f1 r x)) ∘ g = qbs_eval ∘ f" 
    by(auto simp add: case_prod_unfold g_def qbs_eval_def)
  ultimately show "qbs_eval ∘ f ∈ qbs_Mx Y" by simp
qed

lemma curry_morphism:
 "curry ∈ exp_qbs (X ⨂Q Y) Z →Q exp_qbs X (exp_qbs Y Z)"
proof(auto intro!: qbs_morphismI simp: exp_qbs_Mx_def)
  fix k α α'
  assume h:"(λ(r, xy). k r xy) ∈ ℝQ ⨂Q X ⨂Q Y →Q Z"
           "α ∈ pair_qbs_Mx ℝQ X"
           "α' ∈ pair_qbs_Mx ℝQ Y"
  define β where
   "β ≡ (λr. (fst (α (fst (α' r))),(snd (α (fst (α' r))), snd (α' r))))"
  have "(λ(x, y). ((λ(x, y). (curry ∘ k) x y) ∘ α) x y) ∘ α' = (λ(r, xy). k r xy) ∘ β"
    by(simp add: curry_def split_beta' comp_def β_def)
  also have "... ∈ qbs_Mx Z"
  proof -
    have "β ∈ qbs_Mx (ℝQ ⨂Q X ⨂Q Y)"
      using h(2,3) qbs_closed1_dest[of _ _ "(λx. fst (α' x))"]
      by(auto simp: pair_qbs_Mx_def β_def comp_def)
    thus ?thesis
      using h by auto
  qed
  finally show "(λ(x, y). ((λ(x, y). (curry ∘ k) x y) ∘ α) x y) ∘ α' ∈ qbs_Mx Z" .
qed

lemma curry_preserves_morphisms:
  assumes "f ∈ X ⨂Q Y →Q Z"
  shows "curry f ∈ X →Q exp_qbs Y Z"
  by(rule qbs_morphismE(2)[OF curry_morphism,simplified,OF assms])

lemma uncurry_morphism:
 "case_prod ∈ exp_qbs X (exp_qbs Y Z) →Q exp_qbs (X ⨂Q Y) Z"
proof(auto intro!: qbs_morphismI simp: exp_qbs_Mx_def)
  fix k α
  assume h:"(λ(x, y). k x y) ∈ ℝQ ⨂Q X →Q exp_qbs Y Z"
           "α ∈ pair_qbs_Mx ℝQ (X ⨂Q Y)"
  have "(λ(x, y). (case_prod ∘ k) x y) ∘ α = (λ(r,y). k (fst (α r)) (fst (snd (α r))) y) ∘ (λr. (r,snd (snd (α r))))"
    by(simp add: split_beta' comp_def)
  also have "... ∈ qbs_Mx Z"
  proof(rule qbs_morphismE(3)[where X="ℝQ ⨂Q Y"])
    have "(λr. k (fst (α r)) (fst (snd (α r)))) = (λ(x, y). k x y) ∘ (λr. (fst (α r),fst (snd (α r))))"
      by auto
    also have "... ∈ qbs_Mx (exp_qbs Y Z)"
      apply(rule qbs_morphismE(3)[where X="ℝQ ⨂Q X"])
      using h(2) by(auto simp: h(1) pair_qbs_Mx_def comp_def)
    finally show " (λ(r, y). k (fst (α r)) (fst (snd (α r))) y) ∈ ℝQ ⨂Q Y →Q Z"
      by(simp add: exp_qbs_Mx_def)
  next
    show "(λr. (r, snd (snd (α r)))) ∈ qbs_Mx (ℝQ ⨂Q Y)"
      using h(2) by(simp add: pair_qbs_Mx_def comp_def)
  qed
  finally show "(λ(x, y). (case_prod ∘ k) x y) ∘ α ∈ qbs_Mx Z" .
qed

lemma uncurry_preserves_morphisms:
  assumes "f ∈ X →Q exp_qbs Y Z"
  shows "case_prod f ∈ X ⨂Q Y →Q Z"
 by(rule qbs_morphismE(2)[OF uncurry_morphism,simplified,OF assms])

lemma arg_swap_morphism:
  assumes "f ∈ X →Q exp_qbs Y Z"
  shows "(λy x. f x y) ∈ Y →Q exp_qbs X Z"
  using curry_preserves_morphisms[OF qbs_morphism_pair_swap[OF uncurry_preserves_morphisms[OF assms]]]
  by simp

lemma exp_qbs_comp_morphism:
  assumes "f ∈ W →Q exp_qbs X Y"
      and "g ∈ W →Q exp_qbs Y Z"
    shows "(λw. g w ∘ f w) ∈ W →Q exp_qbs X Z"
proof(rule qbs_exp_morphismI)
  fix α β
  assume h: "α ∈ qbs_Mx W"
            "β ∈ pair_qbs_Mx ℝQ X"
  have "(λ(r, x). ((λw. g w ∘ f w) ∘ α) r x) ∘ β= case_prod g ∘ (λr. ((α ∘ (fst ∘ β)) r, case_prod f ((α ∘ (fst ∘ β)) r, (snd ∘ β) r)))"
    by(simp add: split_beta' comp_def)
  also have "... ∈ qbs_Mx Z"
  proof -
    have "(λr. ((α ∘ (fst ∘ β)) r, case_prod f ((α ∘ (fst ∘ β)) r, (snd ∘ β) r))) ∈ qbs_Mx (W ⨂Q Y)"
    proof(auto simp add: pair_qbs_Mx_def)
      have "fst ∘ (λr. (α (fst (β r)), f (α (fst (β r))) (snd (β r)))) = α ∘ (fst ∘ β)"
        by (simp add: comp_def)
      also have "... ∈ qbs_Mx W"
        using qbs_decomp[of W] h
        by(simp add: pair_qbs_Mx_def qbs_closed1_def)
      finally show "fst ∘ (λr. (α (fst (β r)), f (α (fst (β r))) (snd (β r)))) ∈ qbs_Mx W" .
    next
      have [simp]:"snd ∘ (λr. (α (fst (β r)), f (α (fst (β r))) (snd (β r)))) =  case_prod f ∘ (λr. ((α ∘ (fst ∘ β)) r, (snd ∘ β) r))"
        by(simp add: comp_def)
      have "(λr. ((α ∘ (fst ∘ β)) r, (snd ∘ β) r)) ∈ qbs_Mx (W ⨂Q X)"
      proof(auto simp add: pair_qbs_Mx_def)
        have "fst ∘ (λr. (α (fst (β r)), snd (β r)))= α ∘ (fst ∘ β)"
          by (simp add: comp_def)
        also have "... ∈ qbs_Mx W"
          using qbs_decomp[of W] h
          by(simp add: pair_qbs_Mx_def qbs_closed1_def)
        finally show "fst ∘ (λr. (α (fst (β r)), snd (β r))) ∈ qbs_Mx W" .
      next
        show "snd ∘ (λr. (α (fst (β r)), snd (β r))) ∈ qbs_Mx X"
          using h
          by(simp add: pair_qbs_Mx_def comp_def)
      qed
      hence "case_prod f ∘ (λr. ((α ∘ (fst ∘ β)) r, (snd ∘ β) r)) ∈ qbs_Mx Y"
        using uncurry_preserves_morphisms[OF assms(1)] by auto
      thus "snd ∘ (λr. (α (fst (β r)), f (α (fst (β r))) (snd (β r)))) ∈ qbs_Mx Y"
        by simp
    qed
    thus ?thesis
      using uncurry_preserves_morphisms[OF assms(2)]
      by auto
  qed
  finally show "(λ(r, x). ((λw. g w ∘ f w) ∘ α) r x) ∘ β ∈ qbs_Mx Z" .
qed

lemma case_sum_morphism:
 "case_prod case_sum ∈ exp_qbs X Z ⨂Q exp_qbs Y Z  →Q exp_qbs (X <+>Q Y) Z"
proof(rule qbs_exp_morphismI)
  fix α β
  assume h0:"α ∈ qbs_Mx (exp_qbs X Z ⨂Q exp_qbs Y Z)"
            "β ∈ pair_qbs_Mx ℝQ (X <+>Q Y)"
  let ?α1 = "fst ∘ α"
  let ?α2 = "snd ∘ α"
  let ?β1 = "fst ∘ β"
  let ?β2 = "snd ∘ β"
  have h:"?α1 ∈ exp_qbs_Mx X Z"
         "?α2 ∈ exp_qbs_Mx Y Z"
         "?β1 ∈ real_borel →M real_borel"
         "?β2 ∈ copair_qbs_Mx X Y"
    using h0 by (auto simp add: pair_qbs_Mx_def)
  hence "∃S∈sets real_borel. (S = {} ⟶ (∃α1∈qbs_Mx X. ?β2 = (λr. Inl (α1 r)))) ∧
                             (S = UNIV ⟶ (∃α2∈qbs_Mx Y. ?β2 = (λr. Inr (α2 r)))) ∧
                             (S ≠ {} ∧ S ≠ UNIV ⟶
                            (∃α1∈qbs_Mx X. ∃α2∈qbs_Mx Y. ?β2 = (λr. if r ∈ S then Inl (α1 r) else Inr (α2 r))))"
    by(simp add: copair_qbs_Mx_def)
  then obtain S :: "real set" where hs:
   "S∈sets real_borel ∧ (S = {} ⟶ (∃α1∈qbs_Mx X. ?β2 = (λr. Inl (α1 r)))) ∧
                         (S = UNIV ⟶ (∃α2∈qbs_Mx Y. ?β2 = (λr. Inr (α2 r)))) ∧
                         (S ≠ {} ∧ S ≠ UNIV ⟶
                          (∃α1∈qbs_Mx X. ∃α2∈qbs_Mx Y. ?β2 = (λr. if r ∈ S then Inl (α1 r) else Inr (α2 r))))"
    by auto
  show "(λ(r, x). ((λ(x, y). case_sum x y) ∘ α) r x) ∘ β ∈ qbs_Mx Z"
  proof -
    have "(λ(r, x). ((λ(x, y). case_sum x y) ∘ α) r x) ∘ β = (λr. case_sum (?α1 (?β1 r)) (?α2 (?β1 r)) (?β2 r))"
          (is "?lhs = ?rhs")
      by(auto simp: split_beta' comp_def) (metis comp_apply)
    also have "... ∈ qbs_Mx Z"
         (is "?f ∈ _")
    proof -
      consider "S = {}" | "S = UNIV" | "S ≠ {} ∧ S ≠ UNIV" by auto
      then show ?thesis
      proof cases
        case 1
        then obtain α1 where h1:
         "α1∈qbs_Mx X ∧ ?β2 = (λr. Inl (α1 r))"
          using hs by auto
        then have "(λr. case_sum (?α1 (?β1 r)) (?α2 (?β1 r)) (?β2 r)) = (λr. ?α1 (?β1 r) (α1 r))"
          by simp
        also have "... = case_prod ?α1 ∘ (λr. (?β1 r,α1 r))"
          by auto
        also have "... ∈ ℝQ →Q Z"
          apply(rule qbs_morphism_comp[of _ _ "ℝQ ⨂Q X"])
           apply(rule qbs_morphism_tuple)
          using h(3)
            apply blast
          using qbs_Mx_is_morphisms h1
           apply blast
          using qbs_Mx_is_morphisms[of "ℝQ ⨂Q X"] h(1)
          by (simp add: exp_qbs_Mx_def)
        finally show ?thesis
          using qbs_Mx_is_morphisms by auto
      next
        case 2
        then obtain α2 where h2:
         "α2∈qbs_Mx Y ∧ ?β2 = (λr. Inr (α2 r))"
          using hs by auto
        then have "(λr. case_sum (?α1 (?β1 r)) (?α2 (?β1 r)) (?β2 r)) = (λr. ?α2 (?β1 r) (α2 r))"
          by simp
        also have "... = case_prod ?α2 ∘ (λr. (?β1 r,α2 r))"
          by auto
        also have "... ∈ ℝQ →Q Z"
          apply(rule qbs_morphism_comp[of _ _ "ℝQ ⨂Q Y"])
           apply(rule qbs_morphism_tuple)
          using h(3)
            apply blast
          using qbs_Mx_is_morphisms h2
           apply blast
          using qbs_Mx_is_morphisms[of "ℝQ ⨂Q Y"] h(2)
          by (simp add: exp_qbs_Mx_def)
        finally show ?thesis
          using qbs_Mx_is_morphisms by auto
      next
        case 3
        then obtain α1 α2 where h3:
          "α1∈qbs_Mx X ∧ α2∈qbs_Mx Y ∧ ?β2 = (λr. if r ∈ S then Inl (α1 r) else Inr (α2 r))"
          using hs by auto
        define P :: "real ⇒ nat"
          where "P ≡ (λr. if r ∈ S then 0 else 1)"
        define γ :: "nat ⇒ real ⇒ _"
          where "γ ≡ (λn r. if n = 0 then ?α1 (?β1 r) (α1 r) else ?α2 (?β1 r) (α2 r))"
        then have "(λr. case_sum (?α1 (?β1 r)) (?α2 (?β1 r)) (?β2 r)) =(λr. γ (P r) r)"
          by(auto simp add: P_def γ_def h3)
        also have "... ∈ qbs_Mx Z"
        proof -
          have "∀i. P -` {i} ∈ sets real_borel"
            using hs borel_comp[of S] by(simp add: P_def)
          moreover have"∀i. γ i ∈ qbs_Mx Z"
          proof
            fix i :: nat
            consider "i = 0" | "i ≠ 0" by auto
            then show "γ i ∈ qbs_Mx Z"
            proof cases
              case 1
              then have "γ i = (λr. ?α1 (?β1 r) (α1 r))"
                by(simp add: γ_def)
              also have "... = case_prod ?α1 ∘ (λr. (?β1 r,α1 r))"
                by auto
              also have "... ∈ ℝQ →Q Z"
                apply(rule qbs_morphism_comp[of _ _ "ℝQ ⨂Q X"])
                 apply(rule qbs_morphism_tuple)
                using h(3)
                  apply blast
                using qbs_Mx_is_morphisms h3
                 apply blast
                using qbs_Mx_is_morphisms[of "ℝQ ⨂Q X"] h(1)
                by (simp add: exp_qbs_Mx_def)
              finally show ?thesis
                using qbs_Mx_is_morphisms by auto
            next
              case 2
              then have "γ i = (λr. ?α2 (?β1 r) (α2 r))"
                by(simp add: γ_def)
              also have "... = case_prod ?α2 ∘ (λr. (?β1 r,α2 r))"
                by auto
              also have "... ∈ ℝQ →Q Z"
                apply(rule qbs_morphism_comp[of _ _ "ℝQ ⨂Q Y"])
                 apply(rule qbs_morphism_tuple)
                using h(3)
                  apply blast
                using qbs_Mx_is_morphisms h3
                 apply blast
                using qbs_Mx_is_morphisms[of "ℝQ ⨂Q Y"] h(2)
                by (simp add: exp_qbs_Mx_def)
              finally show ?thesis
                using qbs_Mx_is_morphisms by auto
            qed
          qed
          ultimately show ?thesis
            using qbs_decomp[of Z]
            by(simp add: qbs_closed3_def)
        qed
        finally show ?thesis .
      qed
    qed
    finally show ?thesis .
  qed
qed


lemma not_qbs_morphism:
 "Not ∈ 𝔹Q →Q 𝔹Q"
  by(auto intro!: bool_qbs_morphism)

lemma or_qbs_morphism:
 "(∨) ∈ 𝔹Q →Q exp_qbs 𝔹Q 𝔹Q"
  by(auto intro!: bool_qbs_morphism)

lemma and_qbs_morphism:
 "(∧) ∈ 𝔹Q →Q exp_qbs 𝔹Q 𝔹Q"
  by(auto intro!: bool_qbs_morphism)

lemma implies_qbs_morphism:
 "(⟶) ∈ 𝔹Q →Q 𝔹Q ⇒Q 𝔹Q"
  by(auto intro!: bool_qbs_morphism)


lemma less_nat_qbs_morphism:
 "(<) ∈ ℕQ →Q exp_qbs ℕQ 𝔹Q"
  by(auto intro!: nat_qbs_morphism)

lemma less_real_qbs_morphism:
 "(<) ∈ ℝQ →Q exp_qbs ℝQ 𝔹Q"
proof(rule curry_preserves_morphisms[where f="(λ(z :: real × real). fst z < snd z)",simplified curry_def,simplified])
  have "(λz. fst z < snd z) ∈ real_borel ⨂M real_borel →M bool_borel"
    using borel_measurable_pred_less[OF measurable_fst measurable_snd,simplified measurable_cong_sets[OF refl sets_borel_eq_count_space[symmetric],of "borel ⨂M borel"]]
    by simp
  thus "(λz. fst z < snd z) ∈ ℝQ ⨂Q ℝQ →Q 𝔹Q"
    by auto
qed


lemma rec_list_morphism':
 "rec_list' ∈ qbs_space (exp_qbs Y (exp_qbs (exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) (exp_qbs (list_of X) Y)))"
  apply(simp,rule curry_preserves_morphisms[where f="λyf. rec_list' (fst yf) (snd yf)",simplified curry_def, simplified])
  apply(rule arg_swap_morphism)
proof(rule coprod_qbs_canonical1')
  fix n
  show "(λx y. rec_list' (fst y) (snd y) (n, x)) ∈ (ΠQ i∈{..<n}. X) →Q exp_qbs (Y ⨂Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) Y"
  proof(induction n)
    case 0
    show ?case
    proof(rule curry_preserves_morphisms[of " (λ(x,y). rec_list' (fst y) (snd y) (0, x))", simplified],rule qbs_morphismI)
      fix α
      assume h:"α ∈ qbs_Mx ((ΠQ i∈{..<0::nat}. X) ⨂Q Y ⨂Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)))"
      have "⋀r. fst (α r) = (λn. undefined)"
      proof -
        fix r
        have "⋀i. (λr. fst (α r) i) = (λr. undefined)"
          using h by(auto simp: exp_qbs_Mx_def prod_qbs_Mx_def pair_qbs_Mx_def comp_def split_beta')
        thus "fst (α r) = (λn. undefined)"
          by(fastforce dest: fun_cong)
      qed
      hence "(λ(x, y). rec_list' (fst y) (snd y) (0, x)) ∘ α = (λx. fst (snd (α x)))"
        by(auto simp: rec_list'_simp1 comp_def split_beta')
      also have "... ∈ qbs_Mx Y"
        using h by(auto simp: pair_qbs_Mx_def comp_def)
      finally show "(λ(x, y). rec_list' (fst y) (snd y) (0, x)) ∘ α ∈ qbs_Mx Y" .
    qed
  next
    case ih:(Suc n)
    show ?case
    proof(rule qbs_morphismI)
      fix α
      assume h:"α ∈ qbs_Mx (ΠQ i∈{..<Suc n}. X)"
      define α' where "α' ≡ (λr. snd (list_tail (Suc n, α r)))"
      define a where "a ≡ (λr. α r 0)"
      then have ha:"a ∈ qbs_Mx X"
        using h by(auto simp: prod_qbs_Mx_def)
      have 1:"α' ∈ qbs_Mx (ΠQ i∈{..<n}. X)"
        using h by(fastforce simp: prod_qbs_Mx_def list_tail_def α'_def)
      hence 2: "⋀r. (n, α' r) ∈ qbs_space (list_of X)"
        using qbs_Mx_to_X[of α'] by fastforce
      have 3: "⋀r. (Suc n, α r) ∈ qbs_space (list_of X)"
        using qbs_Mx_to_X[of α] h by fastforce
      have 4: "⋀r. (n, α' r) = list_tail (Suc n, α r)"
        by(simp add: list_tail_def α'_def)
      have 5: "⋀r. (Suc n, α r) = list_cons (a r) (n, α' r)"
        unfolding a_def by(simp add: list_simp5[OF 3,simplified 4[symmetric],simplified list_head_def]) auto
      have 6: "(λr. (n, α' r)) ∈ qbs_Mx (list_of X)"
        using 1 by(auto intro!: coprod_qbs_MxI)

      have "(λx y. rec_list' (fst y) (snd y) (Suc n, x)) ∘ α = (λr y. rec_list' (fst y) (snd y) (Suc n, α r))"
        by auto
      also have "... = (λr y. snd y (a r) (n, α' r) (rec_list' (fst y) (snd y) (n, α' r)))"
        by(simp only: 5 rec_list'_simp2[OF 2])
      also have "... ∈ qbs_Mx (exp_qbs (Y ⨂Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) Y)"
      proof -
        have "(λ(r,y). snd y (a r) (n, α' r) (rec_list' (fst y) (snd y) (n, α' r))) = (λ(y,x1,x2,x3). y x1 x2 x3) ∘ (λ(r,y). (snd y, a r, (n, α' r), rec_list' (fst y) (snd y) (n, α' r)))"
          by auto
        also have "... ∈ ℝQ ⨂Q (Y ⨂Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) →Q Y"
        proof(rule qbs_morphism_comp[where Y="exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) ⨂Q X ⨂Q list_of X ⨂Q Y"])
          show "(λ(r, y). (snd y, a r, (n, α' r), rec_list' (fst y) (snd y) (n, α' r))) ∈ ℝQ ⨂Q Y ⨂Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) →Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) ⨂Q X ⨂Q list_of X ⨂Q Y"
          proof(auto simp: split_beta' intro!: qbs_morphism_tuple[OF qbs_morphism_snd''[OF snd_qbs_morphism] qbs_morphism_tuple[of "λ(r, y). a r" "ℝQ ⨂Q Y ⨂Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))" X], OF _ qbs_morphism_tuple[of "λ(r,y).  (n, α' r)"],of "list_of X" "λ(r,y). rec_list' (fst y) (snd y) (n, α' r)",simplified split_beta'])
            show "(λx. a (fst x)) ∈ ℝQ ⨂Q Y ⨂Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) →Q X"
              using ha qbs_Mx_is_morphisms[of X] qbs_morphism_fst''[of a "ℝQ" X] by auto
          next
            show "(λx. (n, α' (fst x))) ∈ ℝQ ⨂Q Y ⨂Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) →Q list_of X"
              using qbs_morphism_fst''[of "λr. (n, α' r)" "ℝQ" "list_of X"] qbs_Mx_is_morphisms[of "list_of X"] 6 by auto
          next
            show "(λx. rec_list' (fst (snd x)) (snd (snd x)) (n, α' (fst x))) ∈ ℝQ ⨂Q Y ⨂Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) →Q Y"
              using qbs_morphismE(3)[OF ih 1, simplified comp_def]  uncurry_preserves_morphisms[of "(λx y. rec_list' (fst y) (snd y) (n, α' x))" "ℝQ" "Y ⨂Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))" Y] qbs_Mx_is_morphisms[of "exp_qbs (Y ⨂Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) Y"]
              by(fastforce simp: split_beta')
          qed
        next
          show "(λ(y, x1, x2, x3). y x1 x2 x3) ∈ exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) ⨂Q X ⨂Q list_of X ⨂Q Y →Q Y"
          proof(rule qbs_morphismI)
            fix β
            assume "β ∈ qbs_Mx (exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) ⨂Q X ⨂Q list_of X ⨂Q Y)"
            then have "∃ β1 β2 β3 β4. β = (λr. (β1 r, β2 r, β3 r, β4 r)) ∧ β1 ∈ qbs_Mx (exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) ∧ β2 ∈ qbs_Mx X ∧ β3 ∈ qbs_Mx (list_of X) ∧ β4 ∈ qbs_Mx Y"
              by(auto intro!: exI[where x="fst ∘ β"] exI[where x="fst ∘ snd ∘ β"] exI[where x="fst ∘ snd ∘ snd ∘ β"] exI[where x="snd ∘ snd ∘ snd ∘ β"] simp:pair_qbs_Mx_def comp_def) 
            then obtain β1 β2 β3 β4 where hb:
             "β = (λr. (β1 r, β2 r, β3 r, β4 r))" "β1 ∈ qbs_Mx (exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)))" "β2 ∈ qbs_Mx X" "β3 ∈ qbs_Mx (list_of X)" "β4 ∈ qbs_Mx Y"
              by auto
            hence hbq:"(λ(((r,x1),x2),x3). β1 r x1 x2 x3) ∈ ((ℝQ ⨂Q X) ⨂Q list_of X) ⨂Q Y →Q Y"
              by(simp add: exp_qbs_Mx_def) (meson uncurry_preserves_morphisms)
            have "(λ(y, x1, x2, x3). y x1 x2 x3) ∘ β = (λ(((r,x1),x2),x3). β1 r x1 x2 x3) ∘ (λr. (((r,β2 r), β3 r), β4 r))"
              by(auto simp: hb(1))
            also have "... ∈ ℝQ →Q Y"
              using hb(2-5)
              by(auto intro!: qbs_morphism_comp[OF qbs_morphism_tuple[OF qbs_morphism_tuple[OF qbs_morphism_tuple[OF qbs_morphism_ident']]] hbq] simp: qbs_Mx_is_morphisms)
            finally show "(λ(y, x1, x2, x3). y x1 x2 x3) ∘ β ∈ qbs_Mx Y"
              by(simp add: qbs_Mx_is_morphisms)
          qed
        qed
        finally show ?thesis
          by(simp add: exp_qbs_Mx_def)
      qed
      finally show "(λx y. rec_list' (fst y) (snd y) (Suc n, x)) ∘ α ∈ qbs_Mx (exp_qbs (Y ⨂Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) Y)" .
    qed
  qed
qed simp


end
e>

Theory Probability_Space_QuasiBorel

(*  Title:   Probability_Space_QuasiBorel.thy
    Author:  Michikazu Hirata, Yasuhiko Minamide, Tokyo Institute of Technology
*)

section ‹Probability Spaces›

subsection ‹Probability Measures ›

theory Probability_Space_QuasiBorel
  imports Exponent_QuasiBorel
begin

subsubsection ‹ Probability Measures ›
type_synonym 'a qbs_prob_t = "'a quasi_borel * (real ⇒ 'a) * real measure"

locale in_Mx =
  fixes X :: "'a quasi_borel"
    and α :: "real ⇒ 'a"
  assumes in_Mx[simp]:"α ∈ qbs_Mx X"

locale qbs_prob = in_Mx X α + real_distribution μ 
  for X :: "'a quasi_borel" and α and μ
begin
declare prob_space_axioms[simp]

lemma m_in_space_prob_algebra[simp]:
 "μ ∈ space (prob_algebra real_borel)"
  using space_prob_algebra[of real_borel] by simp
end

locale pair_qbs_probs = qp1:qbs_prob X α μ + qp2:qbs_prob Y β ν
  for X :: "'a quasi_borel"and α μ and Y :: "'b quasi_borel" and β ν
begin

sublocale pair_prob_space μ ν
  by standard

lemma ab_measurable[measurable]:
 "map_prod α β ∈ real_borel ⨂M real_borel →M qbs_to_measure (X ⨂Q Y)"
  using qbs_morphism_map_prod[of α "ℝQ" X β "ℝQ" Y] qp1.in_Mx qp2.in_Mx l_preserves_morphisms[of "ℝQ ⨂Q ℝQ" "X ⨂Q Y"]
  by(auto simp: qbs_Mx_is_morphisms)

lemma ab_g_in_Mx[simp]:
 "map_prod α β ∘ real_real.g ∈ pair_qbs_Mx X Y"
  using qbs_closed1_dest[OF qp1.in_Mx] qbs_closed1_dest[OF qp2.in_Mx]
  by(auto simp add: pair_qbs_Mx_def comp_def)

sublocale qbs_prob "X ⨂Q Y" "map_prod α β ∘ real_real.g" "distr (μ ⨂M ν) real_borel real_real.f"
  by(auto simp: qbs_prob_def in_Mx_def)

end

locale pair_qbs_prob = qp1:qbs_prob X α μ + qp2:qbs_prob Y β ν
  for X :: "'a quasi_borel"and α μ and Y :: "'a quasi_borel" and β ν
begin

sublocale pair_qbs_probs
  by standard

lemma same_spaces[simp]:
  assumes "Y = X"
  shows "β ∈ qbs_Mx X"
  by(simp add: assms[symmetric])

end

lemma prob_algebra_real_prob_measure:
  "p ∈ space (prob_algebra (real_borel)) = real_distribution p"
proof
  assume "p ∈ space (prob_algebra real_borel)"
  then show "real_distribution p"
    unfolding real_distribution_def real_distribution_axioms_def
    by(simp add: space_prob_algebra sets_eq_imp_space_eq)
next
  assume "real_distribution p"
  then interpret rd: real_distribution p .
  show "p ∈ space (prob_algebra real_borel)"
    by (simp add: space_prob_algebra rd.prob_space_axioms)
qed

lemma qbs_probI:
  assumes "α ∈ qbs_Mx X"
      and "sets μ = sets borel"
      and "prob_space μ"
    shows "qbs_prob X α μ"
  using assms
  by(auto intro!: qbs_prob.intro simp: in_Mx_def real_distribution_def real_distribution_axioms_def)

lemma qbs_empty_not_qbs_prob :"¬ qbs_prob (empty_quasi_borel) f M"
  by(simp add: qbs_prob_def in_Mx_def)

definition qbs_prob_eq :: "['a qbs_prob_t, 'a qbs_prob_t] ⇒ bool" where
  "qbs_prob_eq p1 p2 ≡
   (let (qbs1, a1, m1) = p1;
        (qbs2, a2, m2) = p2 in
    qbs_prob qbs1 a1 m1 ∧ qbs_prob qbs2 a2 m2 ∧ qbs1 = qbs2 ∧
      distr m1 (qbs_to_measure qbs1) a1 = distr m2 (qbs_to_measure qbs2) a2)"

definition qbs_prob_eq2 :: "['a qbs_prob_t, 'a qbs_prob_t] ⇒ bool" where
  "qbs_prob_eq2 p1 p2 ≡
   (let (qbs1, a1, m1) = p1;
        (qbs2, a2, m2) = p2 in
    qbs_prob qbs1 a1 m1 ∧ qbs_prob qbs2 a2 m2 ∧ qbs1 = qbs2 ∧
      (∀f ∈ qbs1 →Q real_quasi_borel. 
           (∫x. f (a1 x) ∂ m1) = (∫x. f (a2 x) ∂ m2)))"

definition qbs_prob_eq3 :: "['a qbs_prob_t, 'a qbs_prob_t] ⇒ bool" where 
  "qbs_prob_eq3 p1 p2 ≡ 
     (let (qbs1, a1, m1) = p1;
          (qbs2, a2, m2) = p2 in
     (qbs_prob qbs1 a1 m1 ∧ qbs_prob qbs2 a2 m2 ∧ qbs1 = qbs2 ∧
      (∀f ∈ qbs1 →Q real_quasi_borel.
         (∀ k ∈ qbs_space qbs1. 0 ≤ f k) ⟶
           (∫x. f (a1 x) ∂ m1) = (∫x. f (a2 x) ∂ m2))))"

definition qbs_prob_eq4 :: "['a qbs_prob_t, 'a qbs_prob_t] ⇒ bool" where
  "qbs_prob_eq4 p1 p2 ≡
     (let (qbs1, a1, m1) = p1;
          (qbs2, a2, m2) = p2 in
     (qbs_prob qbs1 a1 m1 ∧ qbs_prob qbs2 a2 m2 ∧ qbs1 = qbs2 ∧
      (∀f ∈ qbs1 →Q ℝQ≥0. 
           (∫+x. f (a1 x) ∂ m1) = (∫+x. f (a2 x) ∂ m2))))"

lemma(in qbs_prob) qbs_prob_eq_refl[simp]:
 "qbs_prob_eq (X,α,μ) (X,α,μ)"
  by(simp add: qbs_prob_eq_def qbs_prob_axioms)

lemma(in qbs_prob) qbs_prob_eq2_refl[simp]:
 "qbs_prob_eq2 (X,α,μ) (X,α,μ)"
  by(simp add: qbs_prob_eq2_def qbs_prob_axioms)

lemma(in qbs_prob) qbs_prob_eq3_refl[simp]:
 "qbs_prob_eq3 (X,α,μ) (X,α,μ)"
  by(simp add: qbs_prob_eq3_def qbs_prob_axioms)

lemma(in qbs_prob) qbs_prob_eq4_refl[simp]:
 "qbs_prob_eq4 (X,α,μ) (X,α,μ)"
  by(simp add: qbs_prob_eq4_def qbs_prob_axioms)

lemma(in pair_qbs_prob) qbs_prob_eq_intro:
  assumes "X = Y"
      and "distr μ (qbs_to_measure X) α = distr ν (qbs_to_measure X) β"
    shows "qbs_prob_eq (X,α,μ) (Y,β,ν)"
  using assms qp1.qbs_prob_axioms qp2.qbs_prob_axioms 
  by(auto simp add: qbs_prob_eq_def)

lemma(in pair_qbs_prob) qbs_prob_eq2_intro:
  assumes "X = Y"
      and "⋀f. f ∈ qbs_to_measure X →M real_borel
                 ⟹ (∫x. f (α x) ∂ μ) = (∫x. f (β x) ∂ ν)"
    shows "qbs_prob_eq2 (X,α,μ) (Y,β,ν)"
  using assms qp1.qbs_prob_axioms qp2.qbs_prob_axioms 
  by(auto simp add: qbs_prob_eq2_def)

lemma(in pair_qbs_prob) qbs_prob_eq3_intro:
  assumes "X = Y"
      and "⋀f. f ∈ qbs_to_measure X →M real_borel ⟹ (∀ k ∈ qbs_space X. 0 ≤ f k)
                ⟹ (∫x. f (α x) ∂ μ) = (∫x. f (β x) ∂ ν)"
    shows "qbs_prob_eq3 (X,α,μ) (Y,β,ν)"
  using assms qp1.qbs_prob_axioms qp2.qbs_prob_axioms 
  by(auto simp add: qbs_prob_eq3_def)

lemma(in pair_qbs_prob) qbs_prob_eq4_intro:
  assumes "X = Y"
      and "⋀f. f ∈ qbs_to_measure X →M ennreal_borel
                 ⟹ (∫+x. f (α x) ∂ μ) = (∫+x. f (β x) ∂ ν)"
    shows "qbs_prob_eq4 (X,α,μ) (Y,β,ν)"
  using assms qp1.qbs_prob_axioms qp2.qbs_prob_axioms 
  by(auto simp add: qbs_prob_eq4_def)


lemma qbs_prob_eq_dest:
  assumes "qbs_prob_eq (X,α,μ) (Y,β,ν)"
  shows "qbs_prob X α μ"
        "qbs_prob Y β ν"
        "Y = X"
    and "distr μ (qbs_to_measure X) α = distr ν (qbs_to_measure X) β" 
  using assms by(auto simp: qbs_prob_eq_def)

lemma qbs_prob_eq2_dest:
  assumes "qbs_prob_eq2 (X,α,μ) (Y,β,ν)"
  shows "qbs_prob X α μ"
        "qbs_prob Y β ν"
        "Y = X"
    and "⋀f. f ∈ qbs_to_measure X →M real_borel
        ⟹ (∫x. f (α x) ∂ μ) = (∫x. f (β x) ∂ ν)"
  using assms by(auto simp: qbs_prob_eq2_def)

lemma qbs_prob_eq3_dest:
  assumes "qbs_prob_eq3 (X,α,μ) (Y,β,ν)"
  shows "qbs_prob X α μ"
        "qbs_prob Y β ν"
        "Y = X"
    and "⋀f. f ∈ qbs_to_measure X →M real_borel ⟹ (∀ k ∈ qbs_space X. 0 ≤ f k)
        ⟹ (∫x. f (α x) ∂ μ) = (∫x. f (β x) ∂ ν)"
  using assms by(auto simp: qbs_prob_eq3_def)

lemma qbs_prob_eq4_dest:
  assumes "qbs_prob_eq4 (X,α,μ) (Y,β,ν)"
  shows "qbs_prob X α μ"
        "qbs_prob Y β ν"
        "Y = X"
    and "⋀f. f ∈ qbs_to_measure X →M ennreal_borel
        ⟹ (∫+x. f (α x) ∂ μ) = (∫+x. f (β x) ∂ ν)"
  using assms by(auto simp: qbs_prob_eq4_def)

definition qbs_prob_t_ennintegral :: "['a qbs_prob_t, 'a ⇒ ennreal] ⇒ ennreal" where
"qbs_prob_t_ennintegral p f ≡
  (if f ∈ (fst p) →Q ennreal_quasi_borel 
   then (∫+x. f (fst (snd p) x) ∂ (snd (snd p))) else 0)"

definition qbs_prob_t_integral :: "['a qbs_prob_t, 'a ⇒ real] ⇒ real" where
"qbs_prob_t_integral p f ≡ 
  (if f ∈ (fst p) →Q ℝQ
   then (∫x. f (fst (snd p) x) ∂ (snd (snd p)))
   else 0)"

definition qbs_prob_t_integrable :: "['a qbs_prob_t, 'a ⇒ real] ⇒ bool" where
"qbs_prob_t_integrable p f ≡ f ∈ fst p →Q real_quasi_borel ∧ integrable (snd (snd p)) (f ∘ (fst (snd p)))"

definition qbs_prob_t_measure :: "'a qbs_prob_t ⇒ 'a measure" where
"qbs_prob_t_measure p ≡ distr (snd (snd p)) (qbs_to_measure (fst p)) (fst (snd p))"

lemma qbs_prob_eq_symp:
 "symp qbs_prob_eq"
  by(simp add: symp_def qbs_prob_eq_def)

lemma qbs_prob_eq_transp:
 "transp qbs_prob_eq"
  by(simp add: transp_def qbs_prob_eq_def)

quotient_type 'a qbs_prob_space = "'a qbs_prob_t" / partial: qbs_prob_eq
  morphisms rep_qbs_prob_space qbs_prob_space
proof(rule part_equivpI)
  let ?U = "UNIV :: 'a set"
  let ?Uf = "UNIV :: (real ⇒ 'a) set"
  let ?f = "(λ_. undefined) :: real ⇒ 'a"
  have "qbs_prob (Abs_quasi_borel (?U,?Uf)) ?f (return borel 0)"
  proof(auto simp add: qbs_prob_def in_Mx_def)
    have "Rep_quasi_borel (Abs_quasi_borel (?U,?Uf)) = (?U, ?Uf)"
      using Abs_quasi_borel_inverse
      by (auto simp add: qbs_closed1_def qbs_closed2_def qbs_closed3_def is_quasi_borel_def)
    thus "(λ_. undefined) ∈ qbs_Mx (Abs_quasi_borel (?U, ?Uf))"
      by(simp add: qbs_Mx_def)
  next
    show "real_distribution (return borel 0)"
      by (simp add: prob_space_return real_distribution_axioms_def real_distribution_def)
  qed
  thus "∃x :: 'a qbs_prob_t . qbs_prob_eq x x"
    unfolding qbs_prob_eq_def
    by(auto intro!: exI[where x="(Abs_quasi_borel (?U,?Uf), ?f, return borel 0)"])
qed (simp_all add: qbs_prob_eq_symp qbs_prob_eq_transp)

interpretation qbs_prob_space : quot_type "qbs_prob_eq" "Abs_qbs_prob_space" "Rep_qbs_prob_space"
  using Abs_qbs_prob_space_inverse Rep_qbs_prob_space
  by(simp add: quot_type_def equivp_implies_part_equivp qbs_prob_space_equivp Rep_qbs_prob_space_inverse Rep_qbs_prob_space_inject) blast

lemma qbs_prob_space_induct:
  assumes "⋀X α μ. qbs_prob X α μ ⟹ P (qbs_prob_space (X,α,μ))"
  shows "P s"
  apply(rule qbs_prob_space.abs_induct)
  using assms by(auto simp: qbs_prob_eq_def)

lemma qbs_prob_space_induct':
  assumes "⋀X α μ. qbs_prob X α μ ⟹ s = qbs_prob_space (X,α,μ)⟹ P (qbs_prob_space (X,α,μ))"
  shows "P s"
  by (metis (no_types, lifting) Rep_qbs_prob_space_inverse assms case_prodE qbs_prob_eq_def qbs_prob_space.abs_def qbs_prob_space.rep_prop qbs_prob_space_def)

lemma rep_qbs_prob_space:
 "∃X α μ. p = qbs_prob_space (X, α, μ) ∧ qbs_prob X α μ"
  by(rule qbs_prob_space.abs_induct,auto simp add: qbs_prob_eq_def)

lemma(in qbs_prob) in_Rep:
  "(X, α, μ) ∈ Rep_qbs_prob_space (qbs_prob_space (X,α,μ))"
  by (metis mem_Collect_eq qbs_prob_eq_refl qbs_prob_space.abs_def qbs_prob_space.abs_inverse qbs_prob_space_def)

lemma(in qbs_prob) if_in_Rep:
  assumes "(X',α',μ') ∈ Rep_qbs_prob_space (qbs_prob_space (X,α,μ))"
  shows "X' = X"
        "qbs_prob X' α' μ'"
        "qbs_prob_eq (X,α,μ) (X',α',μ')"
proof -
  have h:"X' = X"
    by (metis assms mem_Collect_eq qbs_prob_eq_dest(3) qbs_prob_eq_refl qbs_prob_space.abs_def qbs_prob_space.abs_inverse qbs_prob_space_def)
  have [simp]:"qbs_prob X' α' μ'"
    by (metis assms mem_Collect_eq prod_cases3 qbs_prob_eq_dest(2) qbs_prob_space.rep_prop)
  have [simp]:"qbs_prob_eq (X,α,μ) (X',α',μ')"
    by (metis assms mem_Collect_eq qbs_prob_eq_refl qbs_prob_space.abs_def qbs_prob_space.abs_inverse qbs_prob_space_def)
  show "X' = X"
       "qbs_prob X' α' μ'"
       "qbs_prob_eq (X,α,μ) (X',α',μ')"
    by simp_all (simp add: h)
qed

lemma(in qbs_prob) in_Rep_induct:
  assumes "⋀Y β ν. (Y,β,ν) ∈ Rep_qbs_prob_space (qbs_prob_space (X,α,μ)) ⟹ P (Y,β,ν)"
  shows "P (rep_qbs_prob_space (qbs_prob_space (X,α,μ)))"
  unfolding rep_qbs_prob_space_def qbs_prob_space.rep_def
  by(rule someI2[where a="(X,α,μ)"]) (use in_Rep assms in auto)

(* qbs_prob_eq[1-4] are equivalent. *)
lemma qbs_prob_eq_2_implies_3 :
  assumes "qbs_prob_eq2 p1 p2"
  shows "qbs_prob_eq3 p1 p2"
  using assms by(auto simp: qbs_prob_eq2_def qbs_prob_eq3_def)

lemma qbs_prob_eq_3_implies_1 :
  assumes "qbs_prob_eq3 (p1 :: 'a qbs_prob_t) p2"
  shows "qbs_prob_eq p1 p2"
proof(rule prod_cases3[where y=p1],rule prod_cases3[where y=p2],simp)
  fix X Y :: "'a quasi_borel"
  fix α β μ ν
  assume "p1 = (X,α,μ)" "p2 = (Y,β,ν)"
  then have h:"qbs_prob_eq3 (X,α,μ) (Y,β,ν)"
    using assms by simp
  then interpret qp : pair_qbs_prob X α μ Y β ν
    by(auto intro!: pair_qbs_prob.intro simp: qbs_prob_eq3_def)
  note [simp] = qbs_prob_eq3_dest(3)[OF h]

  show "qbs_prob_eq (X,α,μ) (Y,β,ν)"
  proof(rule qp.qbs_prob_eq_intro)
   show "distr μ (qbs_to_measure X) α = distr ν (qbs_to_measure X) β"
    proof(rule measure_eqI)
      fix U
      assume hu:"U ∈ sets (distr μ (qbs_to_measure X) α)"
      have "measure (distr μ (qbs_to_measure X) α) U = measure (distr ν (qbs_to_measure X) β) U"
            (is "?lhs = ?rhs")
      proof -
        have "?lhs = measure μ (α -` U ∩ space μ)"
          by(rule measure_distr) (use hu in simp_all)
        also have "... = integralL μ (indicat_real (α -` U))"
          by simp
        also have "... = (∫x. indicat_real U (α x) ∂μ)"
          using indicator_vimage[of α U] Bochner_Integration.integral_cong[of μ _ "indicat_real (α -` U)" "λx. indicat_real U (α x)"]
          by auto
        also have "... = (∫x. indicat_real U (β x) ∂ν)"
          using qbs_prob_eq3_dest(4)[OF h,of "indicat_real U"] hu
          by simp
        also have "... = integralL ν (indicat_real (β -` U))"
          using indicator_vimage[of β U,symmetric] Bochner_Integration.integral_cong[of ν _ "λx. indicat_real U (β x)" "indicat_real (β -` U)"]
          by blast
        also have "... = measure ν (β -` U ∩ space ν)"
          by simp
        also have "... = ?rhs"
          by(rule measure_distr[symmetric]) (use hu in simp_all)
        finally show ?thesis .
      qed
      thus "emeasure (distr μ (qbs_to_measure X) α) U = emeasure (distr ν (qbs_to_measure X) β) U"
        using qp.qp2.finite_measure_distr[of β] qp.qp1.finite_measure_distr[of α]
        by(simp add: finite_measure.emeasure_eq_measure)
    qed simp
  qed simp
qed

lemma qbs_prob_eq_1_implies_2 :
  assumes "qbs_prob_eq p1 (p2 :: 'a qbs_prob_t)"
  shows "qbs_prob_eq2 p1 p2"
proof(rule prod_cases3[where y=p1],rule prod_cases3[where y=p2],simp)
  fix X Y :: "'a quasi_borel"
  fix α β μ ν
  assume "p1 = (X,α,μ)" "p2 = (Y,β,ν)"
  then have h:"qbs_prob_eq (X,α,μ) (Y,β,ν)"
    using assms by simp
  then interpret qp : pair_qbs_prob X α μ Y β ν
    by(auto intro!: pair_qbs_prob.intro simp: qbs_prob_eq_def)
  note [simp] = qbs_prob_eq_dest(3)[OF h]

  show "qbs_prob_eq2 (X,α,μ) (Y,β,ν)"
  proof(rule qp.qbs_prob_eq2_intro)
    fix f :: "'a ⇒ real"
    assume [measurable]:"f ∈ borel_measurable (qbs_to_measure X)"
    show "(∫r. f (α r) ∂ μ) = (∫r. f (β r) ∂ ν)"
         (is "?lhs = ?rhs")
    proof -
      have "?lhs = (∫x. f x ∂(distr μ (qbs_to_measure X) α))"
        by(simp add: Bochner_Integration.integral_distr[symmetric])
      also have "... = (∫x. f x ∂(distr ν (qbs_to_measure X) β))"
        by(simp add: qbs_prob_eq_dest(4)[OF h])
      also have "... = ?rhs"
        by(simp add: Bochner_Integration.integral_distr)
      finally show ?thesis .
    qed
  qed simp
qed
 
lemma qbs_prob_eq_1_implies_4 :
  assumes "qbs_prob_eq p1 p2"
  shows "qbs_prob_eq4 p1 p2"
proof(rule prod_cases3[where y=p1],rule prod_cases3[where y=p2],simp)
  fix X Y :: "'a quasi_borel"
  fix α β μ ν
  assume "p1 = (X,α,μ)" "p2 = (Y,β,ν)"
  then have h:"qbs_prob_eq (X,α,μ) (Y,β,ν)"
    using assms by simp
  then interpret qp : pair_qbs_prob X α μ Y β ν
    by(auto intro!: pair_qbs_prob.intro simp: qbs_prob_eq_def)
  note [simp] = qbs_prob_eq_dest(3)[OF h]

  show "qbs_prob_eq4 (X,α,μ) (Y,β,ν)"
  proof(rule qp.qbs_prob_eq4_intro)
    fix f ::"'a ⇒ ennreal"
    assume [measurable]:"f ∈ borel_measurable (qbs_to_measure X)"
    show "(∫+ x. f (α x) ∂μ) = (∫+ x. f (β x) ∂ν)"
         (is "?lhs = ?rhs")
    proof -
      have "?lhs = integralN (distr μ (qbs_to_measure X) α) f"
        by(simp add: nn_integral_distr)
      also have "... = integralN (distr ν (qbs_to_measure X) β) f"
        by(simp add: qbs_prob_eq_dest(4)[OF h])
      also have "... = ?rhs"
        by(simp add: nn_integral_distr)
      finally show ?thesis .
    qed 
  qed simp
qed

lemma qbs_prob_eq_4_implies_3 :
  assumes "qbs_prob_eq4 p1 p2"
  shows "qbs_prob_eq3 p1 p2"
proof(rule prod_cases3[where y=p1],rule prod_cases3[where y=p2],simp)
  fix X Y :: "'a quasi_borel"
  fix α β μ ν
  assume "p1 = (X,α,μ)" "p2 = (Y,β,ν)"
  then have h:"qbs_prob_eq4 (X,α,μ) (Y,β,ν)"
    using assms by simp
  then interpret qp : pair_qbs_prob X α μ Y β ν
    by(auto intro!: pair_qbs_prob.intro simp: qbs_prob_eq4_def)
  note [simp] = qbs_prob_eq4_dest(3)[OF h]

  show "qbs_prob_eq3 (X,α,μ) (Y,β,ν)"
  proof(rule qp.qbs_prob_eq3_intro)
    fix f :: "'a ⇒ real"
    assume [measurable]:"f ∈ borel_measurable (qbs_to_measure X)"
       and h': "∀k∈qbs_space X. 0 ≤ f k"
    show "(∫ x. f (α x) ∂μ) = (∫ x. f (β x) ∂ν)"
         (is "?lhs = ?rhs")
    proof -
      have "?lhs = enn2real (∫+ x. ennreal (f (α x)) ∂μ)"
        using h' by(auto simp: integral_eq_nn_integral[where f="(λx. f (α x))"] qbs_Mx_to_X(2))
      also have "... = enn2real (∫+ x. (ennreal ∘ f) (α x) ∂μ)"
        by simp
      also have "... = enn2real (∫+ x. (ennreal ∘ f) (β x) ∂ν)"
        using qbs_prob_eq4_dest(4)[OF h,of "ennreal ∘ f"] by simp
      also have "... = enn2real (∫+ x. ennreal (f (β x)) ∂ν)"
        by simp
      also have "... = ?rhs"
        using h' by(auto simp: integral_eq_nn_integral[where f="(λx. f (β x))"] qbs_Mx_to_X(2))
      finally show ?thesis .
    qed
  qed simp
qed

lemma qbs_prob_eq_equiv12 :
 "qbs_prob_eq = qbs_prob_eq2"
  using qbs_prob_eq_1_implies_2 qbs_prob_eq_2_implies_3 qbs_prob_eq_3_implies_1
  by blast

lemma qbs_prob_eq_equiv13 :
 "qbs_prob_eq = qbs_prob_eq3"
  using qbs_prob_eq_1_implies_2 qbs_prob_eq_2_implies_3 qbs_prob_eq_3_implies_1
  by blast

lemma qbs_prob_eq_equiv14 :
 "qbs_prob_eq = qbs_prob_eq4"
  using qbs_prob_eq_2_implies_3 qbs_prob_eq_3_implies_1 qbs_prob_eq_1_implies_4 qbs_prob_eq_4_implies_3 qbs_prob_eq_1_implies_2
  by blast

lemma qbs_prob_eq_equiv23 :
 "qbs_prob_eq2 = qbs_prob_eq3"
  using qbs_prob_eq_1_implies_2 qbs_prob_eq_2_implies_3 qbs_prob_eq_3_implies_1
  by blast

lemma qbs_prob_eq_equiv24 :
 "qbs_prob_eq2 = qbs_prob_eq4"
  using qbs_prob_eq_2_implies_3 qbs_prob_eq_4_implies_3 qbs_prob_eq_3_implies_1 qbs_prob_eq_1_implies_4 qbs_prob_eq_1_implies_2
  by blast

lemma qbs_prob_eq_equiv34:
 "qbs_prob_eq3 = qbs_prob_eq4"
  using qbs_prob_eq_3_implies_1 qbs_prob_eq_1_implies_4 qbs_prob_eq_4_implies_3
  by blast

lemma qbs_prob_eq_equiv31 :
 "qbs_prob_eq = qbs_prob_eq3"
  using qbs_prob_eq_1_implies_2 qbs_prob_eq_2_implies_3 qbs_prob_eq_3_implies_1
  by blast

lemma qbs_prob_space_eq:
  assumes "qbs_prob_eq (X,α,μ) (Y,β,ν)"
  shows "qbs_prob_space (X,α,μ) = qbs_prob_space (Y,β,ν)"
  using Quotient3_rel[OF Quotient3_qbs_prob_space] assms
  by blast

lemma(in pair_qbs_prob) qbs_prob_space_eq:
  assumes "Y = X"
      and "distr μ (qbs_to_measure X) α = distr ν (qbs_to_measure X) β"
    shows "qbs_prob_space (X,α,μ) = qbs_prob_space (Y,β,ν)"
  using assms qbs_prob_eq_intro qbs_prob_space_eq by auto

lemma(in pair_qbs_prob) qbs_prob_space_eq2:
  assumes "Y = X"
      and "⋀f. f ∈ qbs_to_measure X →M real_borel
                 ⟹ (∫x. f (α x) ∂ μ) = (∫x. f (β x) ∂ ν)"
    shows "qbs_prob_space (X,α,μ) = qbs_prob_space (Y,β,ν)"
  using qbs_prob_space_eq assms qbs_prob_eq_2_implies_3[of "(X,α,μ)" "(Y,β,ν)"] qbs_prob_eq_3_implies_1[of "(X,α,μ)" "(Y,β,ν)"] qbs_prob_eq2_intro qbs_prob_eq_dest(4)
  by blast

lemma(in pair_qbs_prob) qbs_prob_space_eq3:
  assumes "Y = X"
      and "⋀f. f ∈ qbs_to_measure X →M real_borel ⟹ (∀k∈ qbs_space X. 0 ≤ f k)
                 ⟹ (∫x. f (α x) ∂ μ) = (∫x. f (β x) ∂ ν)"
    shows "qbs_prob_space (X,α,μ) = qbs_prob_space (Y,β,ν)"
  using assms qbs_prob_eq_3_implies_1[of "(X,α,μ)" "(Y,β,ν)"] qbs_prob_eq3_intro qbs_prob_space_eq qbs_prob_eq_dest(4)
  by blast

lemma(in pair_qbs_prob) qbs_prob_space_eq4:
  assumes "Y = X"
      and "⋀f. f ∈ qbs_to_measure X →M ennreal_borel
                 ⟹ (∫+x. f (α x) ∂ μ) = (∫+x. f (β x) ∂ ν)"
    shows "qbs_prob_space (X,α,μ) = qbs_prob_space (Y,β,ν)"
  using assms qbs_prob_eq_4_implies_3[of "(X,α,μ)" "(Y,β,ν)"] qbs_prob_space_eq3[OF assms(1)] qbs_prob_eq3_dest(4) qbs_prob_eq4_intro
  by blast 

lemma(in pair_qbs_prob) qbs_prob_space_eq_inverse:
  assumes "qbs_prob_space (X,α,μ) = qbs_prob_space (Y,β,ν)"
    shows "qbs_prob_eq (X,α,μ) (Y,β,ν)"
      and "qbs_prob_eq2 (X,α,μ) (Y,β,ν)"
      and "qbs_prob_eq3 (X,α,μ) (Y,β,ν)"
      and "qbs_prob_eq4 (X,α,μ) (Y,β,ν)"
  using Quotient3_rel[OF Quotient3_qbs_prob_space,of "(X, α, μ)" "(Y,β,ν)",simplified] assms qp1.qbs_prob_axioms qp2.qbs_prob_axioms
  by(simp_all add: qbs_prob_eq_equiv13[symmetric] qbs_prob_eq_equiv12[symmetric] qbs_prob_eq_equiv14[symmetric])


lift_definition qbs_prob_space_qbs :: "'a qbs_prob_space ⇒ 'a quasi_borel"
is fst by(auto simp add: qbs_prob_eq_def)

lemma(in qbs_prob) qbs_prob_space_qbs_computation[simp]:
 "qbs_prob_space_qbs (qbs_prob_space (X,α,μ)) = X"
  by(simp add: qbs_prob_space_qbs.abs_eq)

lemma rep_qbs_prob_space':
  assumes "qbs_prob_space_qbs s = X"
  shows "∃α μ. s = qbs_prob_space (X,α,μ) ∧ qbs_prob X α μ"
proof -
  obtain X' α μ where hs:
   "s = qbs_prob_space (X', α, μ)" "qbs_prob X' α μ"
    using rep_qbs_prob_space[of s] by auto
  then interpret qp:qbs_prob X' α μ
    by simp
  show ?thesis
    using assms hs(2) by(auto simp add: hs(1))
qed

lift_definition qbs_prob_ennintegral :: "['a qbs_prob_space, 'a ⇒ ennreal] ⇒ ennreal"
is qbs_prob_t_ennintegral
  by(auto simp add: qbs_prob_t_ennintegral_def qbs_prob_eq_equiv14 qbs_prob_eq4_def)

lift_definition qbs_prob_integral :: "['a qbs_prob_space, 'a ⇒ real] ⇒ real"
is qbs_prob_t_integral
  by(auto simp add: qbs_prob_eq_equiv12 qbs_prob_t_integral_def qbs_prob_eq2_def)

syntax
  "_qbs_prob_ennintegral" :: "pttrn ⇒ ennreal ⇒ 'a qbs_prob_space ⇒ ennreal" ("∫+Q((2 _./ _)/ ∂_)" [60,61] 110)

translations
 "∫+Q x. f ∂p" ⇌ "CONST qbs_prob_ennintegral p (λx. f)"

syntax
  "_qbs_prob_integral" :: "pttrn ⇒ real ⇒ 'a qbs_prob_space ⇒ real" ("∫Q((2 _./ _)/ ∂_)" [60,61] 110)

translations
 "∫Q x. f ∂p" ⇌ "CONST qbs_prob_integral p (λx. f)"


text ‹ We define the function ‹lX ∈ L(P(X)) →M G(X)›. ›
lift_definition qbs_prob_measure :: "'a qbs_prob_space ⇒ 'a measure"
is qbs_prob_t_measure
  by(auto simp add: qbs_prob_eq_def qbs_prob_t_measure_def)

declare [[coercion qbs_prob_measure]]

lemma(in qbs_prob) qbs_prob_measure_computation[simp]:
  "qbs_prob_measure (qbs_prob_space (X,α,μ)) = distr μ (qbs_to_measure X) α"
  by (simp add: qbs_prob_measure.abs_eq qbs_prob_t_measure_def)


definition qbs_emeasure ::"'a qbs_prob_space ⇒ 'a set ⇒ ennreal" where
"qbs_emeasure s ≡ emeasure (qbs_prob_measure s)"

lemma(in qbs_prob) qbs_emeasure_computation[simp]:
  assumes "U ∈ sets (qbs_to_measure X)"
  shows "qbs_emeasure (qbs_prob_space (X,α,μ)) U = emeasure μ (α -` U)"
  by(simp add: qbs_emeasure_def emeasure_distr[OF _ assms])


definition qbs_measure ::"'a qbs_prob_space ⇒ 'a set ⇒ real" where
"qbs_measure s ≡ measure (qbs_prob_measure s)"


interpretation qbs_prob_measure_prob_space : prob_space "qbs_prob_measure (s::'a qbs_prob_space)" for s
proof(transfer,auto)
  fix X :: "'a quasi_borel"
  fix α μ
  assume "qbs_prob_eq (X,α,μ) (X,α,μ)"
  then interpret qp: qbs_prob X α μ
    by(simp add: qbs_prob_eq_def)
  show "prob_space (qbs_prob_t_measure (X,α,μ))"
    by(simp add: qbs_prob_t_measure_def qp.prob_space_distr)
qed

lemma qbs_prob_measure_space:
  "qbs_space (qbs_prob_space_qbs s) = space (qbs_prob_measure s)"
  by(transfer,simp add: qbs_prob_t_measure_def)

lemma qbs_prob_measure_sets[measurable_cong]:
  "sets (qbs_to_measure (qbs_prob_space_qbs s)) = sets (qbs_prob_measure s)"
  by(transfer,simp add: qbs_prob_t_measure_def)

lemma(in qbs_prob) qbs_prob_ennintegral_def:
  assumes "f ∈ X →Q ℝQ≥0"
    shows "qbs_prob_ennintegral (qbs_prob_space (X,α,μ)) f = (∫+x. f (α x) ∂ μ)"
  by (simp add: assms qbs_prob_ennintegral.abs_eq qbs_prob_t_ennintegral_def)

lemma(in qbs_prob) qbs_prob_ennintegral_def2:
  assumes "f ∈ X →Q ℝQ≥0"
  shows "qbs_prob_ennintegral (qbs_prob_space (X,α,μ)) f = integralN (distr μ (qbs_to_measure X) α) f"
  using assms by(auto simp add: qbs_prob_ennintegral.abs_eq qbs_prob_t_ennintegral_def qbs_prob_t_measure_def nn_integral_distr)

lemma (in qbs_prob) qbs_prob_ennintegral_not_morphism:
  assumes  "f ∉ X →Q ℝQ≥0"
  shows "qbs_prob_ennintegral (qbs_prob_space (X,α,μ)) f = 0"
  by(simp add: assms qbs_prob_ennintegral.abs_eq qbs_prob_t_ennintegral_def)

lemma qbs_prob_ennintegral_def2:
  assumes "qbs_prob_space_qbs s = (X :: 'a quasi_borel)"
      and "f ∈ X →Q ℝQ≥0"
    shows "qbs_prob_ennintegral s f = integralN (qbs_prob_measure s) f"
  using assms
proof(transfer,auto)
  fix X :: "'a quasi_borel" and α μ f
  assume "qbs_prob_eq (X,α,μ) (X,α,μ)"
     and h:"f ∈ X →Q ℝQ≥0"
  then interpret qp : qbs_prob X α μ
    by(simp add: qbs_prob_eq_def)
  show "qbs_prob_t_ennintegral (X, α, μ) f = integralN (qbs_prob_t_measure (X, α, μ)) f"
    using qp.qbs_prob_ennintegral_def2[OF h]
    by(simp add: qbs_prob_ennintegral.abs_eq qbs_prob_t_measure_def)
qed

lemma(in qbs_prob) qbs_prob_integral_def:
  assumes "f ∈ X →Q real_quasi_borel"
    shows "qbs_prob_integral (qbs_prob_space (X,α,μ)) f = (∫x. f (α x) ∂ μ)"
  by (simp add: assms qbs_prob_integral.abs_eq qbs_prob_t_integral_def)

lemma(in qbs_prob) qbs_prob_integral_def2:
 "qbs_prob_integral (qbs_prob_space (X,α,μ)) f = integralL (distr μ (qbs_to_measure X) α) f"
proof -
  consider "f ∈ X →Q ℝQ" | "f ∉ X →Q ℝQ" by auto
  thus ?thesis
  proof cases
    case h:2
    then have "¬ integrable (qbs_prob_measure (qbs_prob_space (X,α,μ))) f"
      by auto
    thus ?thesis
      using h by(simp add: qbs_prob_integral.abs_eq qbs_prob_t_integral_def not_integrable_integral_eq)
  qed (auto simp add: qbs_prob_integral.abs_eq qbs_prob_t_integral_def integral_distr )
qed

lemma qbs_prob_integral_def2:
  "qbs_prob_integral (s::'a qbs_prob_space) f = integralL (qbs_prob_measure s) f"
proof(transfer,auto)
  fix X :: "'a quasi_borel" and μ α f
  assume "qbs_prob_eq (X,α,μ) (X,α,μ)"
  then interpret qp : qbs_prob X α μ
    by(simp add: qbs_prob_eq_def)
  show "qbs_prob_t_integral (X,α,μ) f = integralL (qbs_prob_t_measure (X,α,μ)) f"
    using qp.qbs_prob_integral_def2
    by(simp add: qbs_prob_t_measure_def qbs_prob_integral.abs_eq)
qed

definition qbs_prob_var :: "'a qbs_prob_space ⇒ ('a ⇒ real) ⇒ real" where
"qbs_prob_var s f ≡ qbs_prob_integral s (λx. (f x - qbs_prob_integral s f)2)"

lemma(in qbs_prob) qbs_prob_var_computation:
  assumes "f ∈ X →Q real_quasi_borel"
  shows "qbs_prob_var (qbs_prob_space (X,α,μ)) f = (∫x. (f (α x) - (∫x. f (α x) ∂ μ))2 ∂ μ)"
proof -
  have "(λx. (f x - qbs_prob_integral (qbs_prob_space (X, α, μ)) f)2) ∈ X →Q ℝQ"
    using assms by auto
  thus ?thesis
    using assms qbs_prob_integral_def[of "λx. (f x - qbs_prob_integral (qbs_prob_space (X,α,μ)) f)2"]
    by(simp add: qbs_prob_var_def qbs_prob_integral_def)
qed

lift_definition qbs_integrable :: "['a qbs_prob_space, 'a ⇒ real] ⇒ bool"
is qbs_prob_t_integrable
proof auto
  have H:"⋀ (X::'a quasi_borel) Y α β μ ν f.
          qbs_prob_eq (X,α,μ) (Y,β,ν) ⟹ qbs_prob_t_integrable (X,α,μ) f ⟹ qbs_prob_t_integrable (Y,β,ν) f"
  proof -
    fix X Y :: "'a quasi_borel"
    fix α β μ ν f
    assume H0:"qbs_prob_eq (X, α, μ) (Y, β, ν)"
              "qbs_prob_t_integrable (X, α, μ) f"
    then interpret qp: pair_qbs_prob X α μ Y β ν
      by(auto intro!: pair_qbs_prob.intro simp: qbs_prob_eq_def)
    have [measurable]: "f ∈ qbs_to_measure X →M real_borel"
                and h: "integrable μ (f ∘ α)"
      using H0 by(auto simp: qbs_prob_t_integrable_def)
    note [simp] = qbs_prob_eq_dest(3)[OF H0(1)]
   
    show "qbs_prob_t_integrable (Y, β, ν) f"
      unfolding qbs_prob_t_integrable_def
    proof auto
      have "integrable (distr μ (qbs_to_measure X) α) f"
        using h by(simp add: comp_def integrable_distr_eq)
      hence "integrable (distr ν (qbs_to_measure X) β) f"
        using qbs_prob_eq_dest(4)[OF H0(1)] by simp
      thus "integrable ν (f ∘ β)"
        by(simp add: comp_def integrable_distr_eq)
    qed
  qed
  fix X Y :: "'a quasi_borel"
  fix α β μ ν
  assume H0:"qbs_prob_eq (X, α, μ) (Y, β, ν)"
  then have H1:"qbs_prob_eq (Y, β, ν) (X, α, μ)"
    by(auto simp add: qbs_prob_eq_def)
  show "qbs_prob_t_integrable (X, α, μ) = qbs_prob_t_integrable (Y, β, ν)"
    using H[OF H0] H[OF H1] by auto
qed

lemma(in qbs_prob) qbs_integrable_def:
 "qbs_integrable (qbs_prob_space (X, α, μ)) f = (f ∈ X →Q ℝQ ∧ integrable μ (f ∘ α))"
  by (simp add: qbs_integrable.abs_eq qbs_prob_t_integrable_def)

lemma qbs_integrable_morphism:
  assumes "qbs_prob_space_qbs s = X"
      and "qbs_integrable s f"
    shows "f ∈ X →Q ℝQ"
  using assms by(transfer,auto simp: qbs_prob_t_integrable_def)

lemma(in qbs_prob) qbs_integrable_measurable[simp,measurable]:
  assumes "qbs_integrable (qbs_prob_space (X,α,μ)) f"
  shows "f ∈ qbs_to_measure X →M real_borel"
  using assms by(auto simp add: qbs_integrable_def)

lemma qbs_integrable_iff_integrable:
  "(qbs_integrable (s::'a qbs_prob_space) f) = (integrable (qbs_prob_measure s) f)"
  apply transfer
  subgoal for s f
  proof(rule prod_cases3[where y=s],simp)
    fix X :: "'a quasi_borel"
    fix α μ
    assume "qbs_prob_eq (X,α,μ) (X,α,μ)"
    then interpret qp: qbs_prob X α μ
      by(simp add: qbs_prob_eq_def)

    show "qbs_prob_t_integrable (X,α,μ) f = integrable (qbs_prob_t_measure (X,α,μ)) f"
         (is "?lhs = ?rhs")
      using integrable_distr_eq[of α μ "qbs_to_measure X" f]
      by(auto simp add: qbs_prob_t_integrable_def qbs_prob_t_measure_def comp_def)
  qed
  done

lemma(in qbs_prob) qbs_integrable_iff_integrable_distr:
 "qbs_integrable (qbs_prob_space (X,α,μ)) f = integrable (distr μ (qbs_to_measure X) α) f"
  by(simp add: qbs_integrable_iff_integrable)

lemma(in qbs_prob) qbs_integrable_iff_integrable:
  assumes "f ∈  qbs_to_measure X →M real_borel"
  shows "qbs_integrable (qbs_prob_space (X,α,μ)) f = integrable μ (λx. f (α x))"
  by(auto intro!: integrable_distr_eq[of α μ "qbs_to_measure X" f] simp: assms qbs_integrable_iff_integrable_distr)

lemma qbs_integrable_if_integrable:
  assumes "integrable (qbs_prob_measure s) f"
  shows "qbs_integrable (s::'a qbs_prob_space) f"
  using assms by(simp add: qbs_integrable_iff_integrable)

lemma integrable_if_qbs_integrable:
  assumes "qbs_integrable (s::'a qbs_prob_space) f"
  shows "integrable (qbs_prob_measure s) f"
  using assms by(simp add: qbs_integrable_iff_integrable)

lemma qbs_integrable_iff_bounded:
  assumes "qbs_prob_space_qbs s = X"
  shows "qbs_integrable s f ⟷ f ∈ X →Q ℝQ ∧ qbs_prob_ennintegral s (λx. ennreal ¦f x ¦) < ∞"
        (is "?lhs = ?rhs")
proof -
  obtain α μ where hs:
   "qbs_prob X α μ" "s = qbs_prob_space (X,α,μ)"
    using rep_qbs_prob_space'[OF assms] by auto
  then interpret qp:qbs_prob X α μ by simp
  have "?lhs = integrable (distr μ (qbs_to_measure X) α) f"
    by (simp add: hs(2) qbs_integrable_iff_integrable)
  also have "... = (f ∈ borel_measurable (distr μ (qbs_to_measure X) α) ∧ ((∫+ x. ennreal (norm (f x)) ∂(distr μ (qbs_to_measure X) α)) < ∞))"
    by(rule integrable_iff_bounded)
  also have "... = ?rhs"
  proof -
    have [simp]:"f ∈ X →Q ℝQ ⟹(λx. ennreal ¦f x¦) ∈ X →Q ℝQ≥0"
      by auto
    have "f ∈ X →Q ℝQ ⟹ qbs_prob_ennintegral s (λx. ennreal ¦f x¦) = (∫+ x. ennreal (norm (f x)) ∂qbs_prob_measure s)"
      using qp.qbs_prob_ennintegral_def2[of "λx. ennreal ¦f x¦"]
      by(auto simp: hs(2))
    thus ?thesis
      by(simp add: hs(2)) fastforce
  qed
  finally show ?thesis .
qed

lemma qbs_integrable_cong:
  assumes "qbs_prob_space_qbs s = X"
          "⋀x. x ∈ qbs_space X ⟹ f x = g x"
      and "qbs_integrable s f"
    shows "qbs_integrable s g"
  apply(rule qbs_integrable_if_integrable)
  using integrable_cong[OF refl, of "qbs_prob_measure s" f g,simplified qbs_prob_measure_space[symmetric] assms(1),OF assms(2)]
        qbs_integrable_iff_integrable[of s f] assms(3)
  by simp

lemma qbs_integrable_const[simp]:
 "qbs_integrable s (λx. c)"
  using qbs_integrable_iff_integrable[of s "λx. c"] by simp

lemma qbs_integrable_add[simp]:
  assumes "qbs_integrable s f"
      and "qbs_integrable s g"
    shows "qbs_integrable s (λx. f x + g x)"
  by(rule qbs_integrable_if_integrable[OF Bochner_Integration.integrable_add[OF integrable_if_qbs_integrable[OF assms(1)] integrable_if_qbs_integrable[OF assms(2)]]])

lemma qbs_integrable_diff[simp]:
  assumes "qbs_integrable s f"
      and "qbs_integrable s g"
    shows "qbs_integrable s (λx. f x - g x)"
  by(rule qbs_integrable_if_integrable[OF Bochner_Integration.integrable_diff[OF integrable_if_qbs_integrable[OF assms(1)] integrable_if_qbs_integrable[OF assms(2)]]])
  
lemma qbs_integrable_mult_iff[simp]:
 "(qbs_integrable s (λx. c * f x)) = (c = 0 ∨ qbs_integrable s f)"
  using qbs_integrable_iff_integrable[of s "λx. c * f x"] integrable_mult_left_iff[of "qbs_prob_measure s" c f] qbs_integrable_iff_integrable[of s f] 
  by simp

lemma qbs_integrable_mult[simp]:
  assumes "qbs_integrable s f"
  shows "qbs_integrable s (λx. c * f x)"
  using assms qbs_integrable_mult_iff by auto

lemma qbs_integrable_abs[simp]:
  assumes "qbs_integrable s f"
  shows "qbs_integrable s (λx. ¦f x¦)"
  by(rule qbs_integrable_if_integrable[OF integrable_abs[OF integrable_if_qbs_integrable[OF assms]]])

lemma qbs_integrable_sq[simp]:
  assumes "qbs_integrable s f"
      and "qbs_integrable s (λx. (f x)2)"
    shows "qbs_integrable s (λx. (f x - c)2)"
  by(simp add: comm_ring_1_class.power2_diff,rule qbs_integrable_diff,rule qbs_integrable_add)
    (simp_all add: comm_semiring_1_class.semiring_normalization_rules(16)[of 2] assms)

lemma qbs_ennintegral_eq_qbs_integral:
  assumes "qbs_prob_space_qbs s = X"
          "qbs_integrable s f"
      and "⋀x. x ∈ qbs_space X ⟹ 0 ≤ f x"
    shows "qbs_prob_ennintegral s (λx. ennreal (f x)) = ennreal (qbs_prob_integral s f)"
  using nn_integral_eq_integral[OF integrable_if_qbs_integrable[OF assms(2)]] assms qbs_prob_ennintegral_def2[OF assms(1) qbs_morphism_comp[OF qbs_integrable_morphism[OF assms(1,2)],of ennreal "ℝQ≥0",simplified comp_def]] measurable_ennreal
  by (metis AE_I2 qbs_prob_integral_def2 qbs_prob_measure_space real.standard_borel_r_full_faithful)

lemma qbs_prob_ennintegral_cong:
  assumes "qbs_prob_space_qbs s = X"
      and "⋀x. x ∈ qbs_space X ⟹ f x = g x"
    shows "qbs_prob_ennintegral s f = qbs_prob_ennintegral s g"
proof -
  obtain α μ where hs:
  "s = qbs_prob_space (X, α, μ)" "qbs_prob X α μ"
    using rep_qbs_prob_space'[OF assms(1)] by auto
  then interpret qp : qbs_prob  X α μ
    by simp
  have H1:"f ∘ α = g ∘ α"
    using assms(2)
    unfolding comp_def apply standard
    using assms(2)[of "α _"] by (simp add: qbs_Mx_to_X(2))
  consider "f ∈ X →Q ℝQ≥0" | "f ∉ X →Q ℝQ≥0" by auto
  then have "qbs_prob_t_ennintegral (X,α,μ) f = qbs_prob_t_ennintegral (X,α,μ) g"
  proof cases
    case h:1
    then have "g ∈ X →Q ℝQ≥0"
      using qbs_morphism_cong[of X f g "ℝQ≥0"] assms by simp
    then show ?thesis
      using h H1 by(simp add: qbs_prob_t_ennintegral_def comp_def)
  next
    case h:2
    then have "g ∉ X →Q ℝQ≥0"
      using assms qbs_morphism_cong[of X g f "ℝQ≥0"] by auto
    then show ?thesis
      using h by(simp add: qbs_prob_t_ennintegral_def)
  qed
  thus ?thesis
    using hs(1) by (simp add: qbs_prob_ennintegral.abs_eq)
qed


lemma qbs_prob_ennintegral_const:
 "qbs_prob_ennintegral (s::'a qbs_prob_space) (λx. c) = c"
  using qbs_prob_ennintegral_def2[OF _ qbs_morphism_const[of c "ℝQ≥0" "qbs_prob_space_qbs s",simplified]]
  by (simp add: qbs_prob_measure_prob_space.emeasure_space_1)

lemma qbs_prob_ennintegral_add:
  assumes "qbs_prob_space_qbs s = X"
          "f ∈ (X::'a quasi_borel) →Q ℝQ≥0"
      and "g ∈ X →Q ℝQ≥0"
    shows "qbs_prob_ennintegral s (λx. f x + g x) = qbs_prob_ennintegral s f + qbs_prob_ennintegral s g"
  using qbs_prob_ennintegral_def2[of s X "λx. f x + g x"] qbs_prob_ennintegral_def2[OF assms(1,2)] qbs_prob_ennintegral_def2[OF assms(1,3)] assms nn_integral_add[of f "qbs_prob_measure s" g]
  by fastforce

lemma qbs_prob_ennintegral_cmult:
  assumes "qbs_prob_space_qbs s = X"
      and "f ∈ X →Q ℝQ≥0"
  shows "qbs_prob_ennintegral s (λx. c * f x) = c * qbs_prob_ennintegral s f"
  using qbs_prob_ennintegral_def2[OF assms(1),of "λx. c * f x"] qbs_prob_ennintegral_def2[OF assms(1,2)] nn_integral_cmult[of f "qbs_prob_measure s"] assms
  by fastforce

lemma qbs_prob_ennintegral_cmult_noninfty:
  assumes "c ≠ ∞"
  shows "qbs_prob_ennintegral s (λx. c * f x) = c * qbs_prob_ennintegral s f"
proof -
  obtain X α μ where hs:
   "s = qbs_prob_space (X, α, μ)" "qbs_prob X α μ"
    using rep_qbs_prob_space[of s] by auto
  then interpret qp: qbs_prob X α μ by simp
  consider "f ∈ X →Q ℝQ≥0" | "f ∉ X →Q ℝQ≥0" by auto
  then show ?thesis
  proof cases
    case 1
    then show ?thesis
      by(auto intro!: qbs_prob_ennintegral_cmult[where X=X] simp: hs(1))
  next
    case 2
    consider "c = 0" | "c ≠ 0 ∧ c ≠ ∞"
      using assms by auto
    then show ?thesis
    proof cases
      case 1
      then show ?thesis
        by(simp add: hs qbs_prob_ennintegral.abs_eq qbs_prob_t_ennintegral_def)
    next
      case h:2
      have "(λx. c * f x) ∉ X →Q ℝQ≥0"
      proof(rule ccontr)
        assume "¬ (λx. c * f x) ∉ X →Q ℝQ≥0"
        hence 3:"(λx. c * f x) ∈ qbs_to_measure X →M ennreal_borel"
          by auto
        have "f = (λx. (1/c) *  (c * f x))"
          using h by(simp add: divide_eq_1_ennreal ennreal_divide_times mult.assoc mult.commute[of c] mult_divide_eq_ennreal)
        also have "... ∈ qbs_to_measure X →M ennreal_borel"
          using 3 by simp
        finally show False
          using 2 by auto
      qed
      thus ?thesis
        using qp.qbs_prob_ennintegral_not_morphism 2
        by(simp add: hs(1))
    qed
  qed
qed

lemma qbs_prob_integral_cong:
  assumes "qbs_prob_space_qbs s = X"
      and "⋀x. x ∈ qbs_space X ⟹ f x = g x"
    shows "qbs_prob_integral s f = qbs_prob_integral s g"
  by(simp add: qbs_prob_integral_def2) (metis Bochner_Integration.integral_cong assms(1) assms(2) qbs_prob_measure_space)

lemma qbs_prob_integral_nonneg:
  assumes "qbs_prob_space_qbs s = X"
      and "⋀x. x ∈ qbs_space X ⟹ 0 ≤ f x"
  shows "0 ≤ qbs_prob_integral s f"
  using qbs_prob_measure_space[of s] assms
  by(simp add: qbs_prob_integral_def2)

lemma qbs_prob_integral_mono:
  assumes "qbs_prob_space_qbs s = X"
          "qbs_integrable (s :: 'a qbs_prob_space) f"
          "qbs_integrable s g"
      and "⋀x. x ∈ qbs_space X ⟹ f x ≤ g x"
    shows "qbs_prob_integral s f ≤ qbs_prob_integral s g"
  using integral_mono[OF integrable_if_qbs_integrable[OF assms(2)] integrable_if_qbs_integrable[OF assms(3)] assms(4)[simplified qbs_prob_measure_space]]
  by(simp add: qbs_prob_integral_def2 assms(1) qbs_prob_measure_space[symmetric])

lemma qbs_prob_integral_const:
  "qbs_prob_integral (s::'a qbs_prob_space) (λx. c) = c"
  by(simp add: qbs_prob_integral_def2 qbs_prob_measure_prob_space.prob_space)

lemma qbs_prob_integral_add:
  assumes "qbs_integrable (s::'a qbs_prob_space) f"
      and "qbs_integrable s g"
    shows "qbs_prob_integral s (λx. f x + g x) = qbs_prob_integral s f + qbs_prob_integral s g"
  using Bochner_Integration.integral_add[OF integrable_if_qbs_integrable[OF assms(1)] integrable_if_qbs_integrable[OF assms(2)]]
  by(simp add: qbs_prob_integral_def2)

lemma qbs_prob_integral_diff:
  assumes "qbs_integrable (s::'a qbs_prob_space) f"
      and "qbs_integrable s g"
    shows "qbs_prob_integral s (λx. f x - g x) = qbs_prob_integral s f - qbs_prob_integral s g"
  using Bochner_Integration.integral_diff[OF integrable_if_qbs_integrable[OF assms(1)] integrable_if_qbs_integrable[OF assms(2)]]
  by(simp add: qbs_prob_integral_def2)

lemma qbs_prob_integral_cmult:
  "qbs_prob_integral s (λx. c * f x) = c * qbs_prob_integral s f"
  by(simp add: qbs_prob_integral_def2)

lemma real_qbs_prob_integral_def:
  assumes "qbs_integrable (s::'a qbs_prob_space) f"
  shows "qbs_prob_integral s f = enn2real (qbs_prob_ennintegral s (λx. ennreal (f x))) - enn2real (qbs_prob_ennintegral s (λx. ennreal (- f x)))"
  using assms
proof(transfer,auto)
  fix X :: "'a quasi_borel"
  fix α μ f
  assume H:"qbs_prob_eq (X,α,μ) (X,α,μ)"
           "qbs_prob_t_integrable (X,α,μ) f"
  then interpret qp: qbs_prob X α μ
    by(simp add: qbs_prob_eq_def)
  show "qbs_prob_t_integral (X,α,μ) f = enn2real (qbs_prob_t_ennintegral (X,α,μ) (λx. ennreal (f x))) - enn2real (qbs_prob_t_ennintegral (X,α,μ) (λx. ennreal (- f x)))"
    using H(2) real_lebesgue_integral_def[of μ "f ∘ α"]
    by(auto simp add: comp_def qbs_prob_t_integrable_def qbs_prob_t_integral_def qbs_prob_t_ennintegral_def)
qed

lemma qbs_prob_var_eq:
  assumes "qbs_integrable (s::'a qbs_prob_space) f"
      and "qbs_integrable s (λx. (f x)2)"
    shows "qbs_prob_var s f = qbs_prob_integral s (λx. (f x)2) - (qbs_prob_integral s f)2"
  unfolding qbs_prob_var_def using assms
proof(transfer,auto)
  fix X :: "'a quasi_borel"
  fix α μ f
  assume H:"qbs_prob_eq (X,α,μ) (X,α,μ)"
           "qbs_prob_t_integrable (X,α,μ) f"
           "qbs_prob_t_integrable (X,α,μ) (λx. (f x)2)"
  then interpret qp: qbs_prob X α μ
    by(simp add: qbs_prob_eq_def)
  show "qbs_prob_t_integral (X,α,μ) (λx. (f x - qbs_prob_t_integral (X,α,μ) f)2) = qbs_prob_t_integral (X,α,μ) (λx. (f x)2) - (qbs_prob_t_integral (X,α,μ) f)2"
    using H(2,3) prob_space.variance_eq[of μ "f ∘ α"]
    by(auto simp add: qbs_prob_t_integral_def qbs_prob_def qbs_prob_t_integrable_def comp_def qbs_prob_eq_def)
qed

lemma qbs_prob_var_affine:
  assumes "qbs_integrable s f"
  shows "qbs_prob_var s (λx. a * f x + b) = a2 * qbs_prob_var s f"
        (is "?lhs = ?rhs")
proof -
  have "?lhs = qbs_prob_integral s (λx. (a * f x + b - (a * qbs_prob_integral s f + b))2)"
    using qbs_prob_integral_add[OF qbs_integrable_mult[OF assms,of a] qbs_integrable_const[of s b]]
    by (simp add: qbs_prob_integral_cmult qbs_prob_integral_const qbs_prob_var_def)
  also have "... = qbs_prob_integral s (λx. (a * f x - a * qbs_prob_integral s f)2)"
    by simp
  also have "... = qbs_prob_integral s (λx. a2 * (f x - qbs_prob_integral s f)2)"
    by (metis power_mult_distrib right_diff_distrib)
  also have "... = ?rhs"
    by(simp add: qbs_prob_var_def qbs_prob_integral_cmult[of s "a2"])
  finally show ?thesis .
qed

lemma qbs_prob_integral_Markov_inequality:
  assumes "qbs_prob_space_qbs s = X"
      and "qbs_integrable s f"
          "⋀x. x ∈ qbs_space X ⟹ 0 ≤ f x"
      and "0 < c"
    shows "qbs_emeasure s {x ∈ qbs_space X. c ≤ f x} ≤ ennreal (1/c * qbs_prob_integral s f)"
  using integral_Markov_inequality[OF integrable_if_qbs_integrable[OF assms(2)] _ assms(4)] assms(3)
  by(force simp add: qbs_prob_integral_def2 qbs_prob_measure_space qbs_emeasure_def assms(1) qbs_prob_measure_space[symmetric])

lemma qbs_prob_integral_Markov_inequality':
  assumes "qbs_prob_space_qbs s = X"
          "qbs_integrable s f"
          "⋀x. x ∈ qbs_space (qbs_prob_space_qbs s) ⟹ 0 ≤ f x"
      and "0 < c"
    shows "qbs_measure s {x ∈ qbs_space (qbs_prob_space_qbs s). c ≤ f x} ≤ (1/c * qbs_prob_integral s f)"
  using qbs_prob_integral_Markov_inequality[OF assms] ennreal_le_iff[of "1/c * qbs_prob_integral s f" "qbs_measure s {x ∈ qbs_space (qbs_prob_space_qbs s). c ≤ f x}"] qbs_prob_integral_nonneg[of s X f,OF assms(1,3)] assms(4)
  by(simp add: qbs_measure_def qbs_emeasure_def qbs_prob_measure_prob_space.emeasure_eq_measure assms(1))

lemma qbs_prob_integral_Markov_inequality_abs:
  assumes "qbs_prob_space_qbs s = X"
          "qbs_integrable s f"
      and "0 < c"
    shows "qbs_emeasure s {x ∈ qbs_space X. c ≤ ¦f x¦} ≤ ennreal (1/c * qbs_prob_integral s (λx. ¦f x¦))"
  using qbs_prob_integral_Markov_inequality[OF assms(1) qbs_integrable_abs[OF assms(2)] _ assms(3)]
  by(simp add: assms(1))

lemma qbs_prob_integral_Markov_inequality_abs':
  assumes "qbs_prob_space_qbs s = X"
          "qbs_integrable s f"
      and "0 < c"
    shows "qbs_measure s {x ∈ qbs_space X. c ≤ ¦f x¦} ≤ (1/c * qbs_prob_integral s (λx. ¦f x¦))"
  using qbs_prob_integral_Markov_inequality'[OF assms(1) qbs_integrable_abs[OF assms(2)] _ assms(3)]
  by(simp add: assms(1))

lemma qbs_prob_integral_real_Markov_inequality:
  assumes "qbs_prob_space_qbs s = ℝQ"
          "qbs_integrable s f"
      and "0 < c"
    shows "qbs_emeasure s {r. c ≤ ¦f r¦} ≤ ennreal (1/c * qbs_prob_integral s (λx. ¦f x¦))"
  using qbs_prob_integral_Markov_inequality_abs[OF assms]
  by simp

lemma qbs_prob_integral_real_Markov_inequality':
  assumes "qbs_prob_space_qbs s = ℝQ"
          "qbs_integrable s f"
      and "0 < c"
    shows "qbs_measure s {r. c ≤ ¦f r¦} ≤ 1/c * qbs_prob_integral s (λx. ¦f x¦)"
  using qbs_prob_integral_Markov_inequality_abs'[OF assms]
  by simp

lemma qbs_prob_integral_Chebyshev_inequality:
  assumes "qbs_prob_space_qbs s = X"
          "qbs_integrable s f"
          "qbs_integrable s (λx. (f x)2)"
      and "0 < b"
    shows "qbs_measure s {x ∈ qbs_space X. b ≤ ¦f x - qbs_prob_integral s f¦} ≤ 1 / b2 * qbs_prob_var s f"
proof -
  have "qbs_integrable s (λx. ¦f x - qbs_prob_integral s f¦2)"
    by(simp, rule qbs_integrable_sq[OF assms(2,3)])
  moreover have "{x ∈ qbs_space X. b2 ≤ ¦f x - qbs_prob_integral s f¦2} = {x ∈ qbs_space X. b ≤ ¦f x - qbs_prob_integral s f¦}"
    by (metis (mono_tags, opaque_lifting) abs_le_square_iff abs_of_nonneg assms(4) less_imp_le power2_abs)
  ultimately show ?thesis
    using qbs_prob_integral_Markov_inequality'[OF assms(1),of "λx. ¦f x - qbs_prob_integral s f¦^2" "b^2"] assms(4)
    by(simp add: qbs_prob_var_def assms(1))
qed

end

Theory Monad_QuasiBorel

(*  Title:   Monad_QuasiBorel.thy
    Author:  Michikazu Hirata, Tetsuya Sato, Tokyo Institute of Technology
*)

subsection ‹The Probability Monad›

theory Monad_QuasiBorel
  imports "Probability_Space_QuasiBorel"
begin

subsubsection ‹ The Probability Monad $P$ ›
definition monadP_qbs_Px :: "'a quasi_borel ⇒ 'a qbs_prob_space set" where
"monadP_qbs_Px X ≡ {s. qbs_prob_space_qbs s = X}"

locale in_Px =
  fixes X :: "'a quasi_borel" and s :: "'a qbs_prob_space" 
  assumes in_Px:"s ∈ monadP_qbs_Px X"
begin

lemma qbs_prob_space_X[simp]:
 "qbs_prob_space_qbs s = X"
  using in_Px by(simp add: monadP_qbs_Px_def)

end

locale in_MPx =
  fixes X :: "'a quasi_borel" and β :: "real ⇒ 'a qbs_prob_space"
  assumes ex:"∃α∈ qbs_Mx X. ∃g ∈ real_borel →M prob_algebra real_borel.
                         ∀r. β r = qbs_prob_space (X,α,g r)"
begin

lemma rep_inMPx:
 "∃α g. α ∈ qbs_Mx X ∧ g ∈ real_borel →M prob_algebra real_borel ∧
        β = (λr. qbs_prob_space (X,α,g r))"
proof -
  obtain α g where hb:
   "α ∈ qbs_Mx X" "g ∈ real_borel →M prob_algebra real_borel"
        "β = (λr. qbs_prob_space (X,α,g r))"
    using ex by auto
  thus ?thesis
    by(auto intro!: exI[where x=α] exI[where x=g] simp: hb)
qed

end

definition monadP_qbs_MPx :: "'a quasi_borel ⇒ (real ⇒ 'a qbs_prob_space) set" where
"monadP_qbs_MPx X ≡ {β. in_MPx X β}"

definition monadP_qbs :: "'a quasi_borel ⇒ 'a qbs_prob_space quasi_borel" where
"monadP_qbs X ≡ Abs_quasi_borel (monadP_qbs_Px X, monadP_qbs_MPx X)"

lemma(in qbs_prob) qbs_prob_space_in_Px:
  "qbs_prob_space (X,α,μ) ∈ monadP_qbs_Px X"
  using qbs_prob_axioms by(simp add: monadP_qbs_Px_def)

lemma rep_monadP_qbs_Px:
  assumes "s ∈ monadP_qbs_Px X"
  shows "∃α μ. s = qbs_prob_space (X, α, μ) ∧ qbs_prob X α μ"
  using rep_qbs_prob_space' assms in_Px.qbs_prob_space_X
  by(auto simp: monadP_qbs_Px_def)

lemma rep_monadP_qbs_MPx:
  assumes "β ∈ monadP_qbs_MPx X"
  shows "∃α g. α ∈ qbs_Mx X ∧ g ∈ real_borel →M prob_algebra real_borel ∧
        β = (λr. qbs_prob_space (X,α,g r))"
  using assms in_MPx.rep_inMPx
  by(auto simp: monadP_qbs_MPx_def)

lemma qbs_prob_MPx:
  assumes "α ∈ qbs_Mx X"
      and "g ∈ real_borel →M prob_algebra real_borel"
    shows "qbs_prob X α (g r)"
  using measurable_space[OF assms(2)]
  by(auto intro!: qbs_prob.intro simp: space_prob_algebra in_Mx_def real_distribution_def real_distribution_axioms_def assms(1))

lemma monadP_qbs_f[simp]: "monadP_qbs_MPx X ⊆ UNIV → monadP_qbs_Px X"
  unfolding monadP_qbs_MPx_def
proof auto
  fix β r
  assume "in_MPx X β"
  then obtain α g where hb:
   "α ∈ qbs_Mx X" "g ∈ real_borel →M prob_algebra real_borel"
        "β = (λr. qbs_prob_space (X,α,g r))"
    using in_MPx.rep_inMPx by blast
  then interpret qp : qbs_prob X α "g r"
    by(simp add: qbs_prob_MPx)
  show "β r ∈ monadP_qbs_Px X"
    by(simp add: hb(3) qp.qbs_prob_space_in_Px)
qed

lemma monadP_qbs_closed1: "qbs_closed1 (monadP_qbs_MPx X)"
  unfolding monadP_qbs_MPx_def in_MPx_def
  apply(rule qbs_closed1I)
  subgoal for α f
    apply auto
    subgoal for β g
      apply(auto intro!: bexI[where x=β] bexI[where x="g∘f"])
      done
    done
  done

lemma monadP_qbs_closed2: "qbs_closed2 (monadP_qbs_Px X) (monadP_qbs_MPx X)"
  unfolding qbs_closed2_def
proof
  fix s
  assume "s ∈ monadP_qbs_Px X"
  then obtain α μ where h:
   "qbs_prob X α μ" "s = qbs_prob_space (X, α, μ)"
    using rep_qbs_prob_space'[of s X] monadP_qbs_Px_def by blast
  then interpret qp : qbs_prob X α μ
    by simp
  define g :: "real ⇒ real measure"
    where "g ≡ (λ_. μ)"
  have "g ∈ real_borel →M prob_algebra real_borel"
    using h prob_algebra_real_prob_measure[of μ]
    by(simp add: qbs_prob_def g_def)
  thus "(λr. s) ∈ monadP_qbs_MPx X"
    by(auto intro!: bexI[where x=α] bexI[where x=g] simp: monadP_qbs_MPx_def in_MPx_def g_def h)
qed

lemma monadP_qbs_closed3: "qbs_closed3 (monadP_qbs_MPx (X :: 'a quasi_borel))"
proof(rule qbs_closed3I)
  fix P :: "real ⇒ nat"
  fix Fi
  assume "⋀i. P -` {i} ∈ sets real_borel"
  then have HP_mble[measurable] : "P ∈ real_borel →M nat_borel"
    by (simp add: separate_measurable)
  assume "⋀i :: nat. Fi i ∈ monadP_qbs_MPx X"
  then have "∀i. ∃αi. ∃gi. αi ∈ qbs_Mx X ∧ gi ∈ real_borel →M prob_algebra real_borel ∧
                    Fi i = (λr. qbs_prob_space (X, αi, gi r))"
    using in_MPx.rep_inMPx[of X] by(simp add: monadP_qbs_MPx_def)
  hence "∃α. ∀i. ∃gi. α i ∈ qbs_Mx X ∧ gi ∈ real_borel →M prob_algebra real_borel ∧
                    Fi i = (λr. qbs_prob_space (X, α i, gi r))"
    by(rule choice)
  then obtain α :: "nat ⇒ real ⇒ _" where
       "∀i. ∃gi. α i ∈ qbs_Mx X ∧ gi ∈ real_borel →M prob_algebra real_borel ∧
                     Fi i = (λr. qbs_prob_space (X, α i, gi r))"
    by auto
  hence  "∃g. ∀i. α i ∈ qbs_Mx X ∧ g i ∈ real_borel →M prob_algebra real_borel ∧
                  Fi i = (λr. qbs_prob_space (X, α i, g i r))"
    by(rule choice)
  then obtain g :: "nat ⇒ real ⇒ real measure" where 
       H0: "⋀i. α i ∈ qbs_Mx X" "⋀i. g i ∈ real_borel →M prob_algebra real_borel"
           "⋀i. Fi i = (λr. qbs_prob_space (X, α i, g i r))"
    by blast
  hence LHS: "(λr. Fi (P r) r) = (λr. qbs_prob_space (X, α (P r), g (P r) r))"
    by auto

  ― ‹ Since ‹ℕ×ℝ› is standard, we have measurable functions
        ‹nat_real.f ∈ ℕ ⨂M ℝ →M ℝ› and ‹nat_real.g ∈ ℝ →M ℕ ⨂M ℝ›
       such that @{thm nat_real.gf_comp_id'(1)}. ›
       
  ― ‹ The proof is divided into 3 steps.
       \begin{enumerate}
       \item  Let ‹α'' = uncurry α ∘ nat_real.g›. Then ‹α'' ∈ qbs_Mx X›.
       \item Let ‹g'' = G(nat_real.f) ∘ (λr. δP(r) ⨂M gP(r) r›.
               Then ‹g''› is ‹ℝ›/‹G(ℝ)› measurable. 
       \item Show that ‹(λr. Fi (P r) r) = (λr. qbs_prob_space (X, α'', g'' r))›.
       \end{enumerate}›

  ― ‹ Step 1.›
  define α' :: "nat × real ⇒ 'a"
    where "α' ≡ case_prod α"
  define α'' :: "real ⇒ 'a"
    where "α'' ≡ α' ∘ nat_real.g"

  have α_morp: "α ∈ ℕQ →Q exp_qbs ℝQ X"
    using qbs_Mx_is_morphisms[of X] H0(1)
    by(auto intro!: nat_qbs_morphism)
  hence α'_morp: "α' ∈ ℕQ ⨂Q ℝQ  →Q X"
    unfolding α'_def
    by(intro uncurry_preserves_morphisms)
  hence [measurable]:"α' ∈ nat_borel ⨂M real_borel →M qbs_to_measure X"
    using l_preserves_morphisms[of "ℕQ ⨂Q ℝQ" X]
    by(auto simp add: r_preserves_product)
  have H_Mx:"α'' ∈ qbs_Mx X"
    unfolding α''_def
    using qbs_morphism_comp[OF real.qbs_morphism_measurable_intro[OF nat_real.g_meas,simplified r_preserves_product] α'_morp] qbs_Mx_is_morphisms[of X]
    by simp


  ― ‹ Step 2.›
  define g' :: "real ⇒ (nat × real) measure"
    where "g' ≡ (λr. return nat_borel (P r) ⨂M g (P r) r)"
  define g'' :: "real ⇒ real measure"
    where "g'' ≡ (λM. distr M real_borel nat_real.f) ∘ g'"

  have [measurable]:"(λnr. g (fst nr) (snd nr)) ∈ nat_borel ⨂M real_borel →M prob_algebra real_borel"
    using measurable_pair_measure_countable1[of "UNIV :: nat set" "λnr. g (fst nr) (snd nr)",simplified,OF H0(2)] measurable_cong_sets[OF sets_pair_measure_cong[of nat_borel "count_space UNIV" real_borel real_borel,OF sets_borel_eq_count_space refl] refl,of "prob_algebra real_borel"]
    by auto    
  hence [measurable]:"(λr. g (P r) r) ∈ real_borel →M prob_algebra real_borel"
  proof -
    have "(λr. g (P r) r) = (λnr. g (fst nr) (snd nr)) ∘ (λr. (P r, r))" by auto
    also have "... ∈ real_borel →M prob_algebra real_borel"
      by simp
    finally show ?thesis .
  qed
  have g'_mble[measurable]:"g' ∈ real_borel →M prob_algebra (nat_borel ⨂M real_borel)"
    unfolding g'_def by simp
  have H_mble: "g'' ∈ real_borel →M prob_algebra real_borel"
    unfolding g''_def by simp

  ― ‹ Step 3.›
  have H_equiv: 
       "qbs_prob_space (X, α (P r), g (P r) r) = qbs_prob_space (X, α'', g'' r)" for r
  proof -
    interpret pqp: pair_qbs_prob X "α (P r)" "g (P r) r" X α'' "g'' r"
      using qbs_prob_MPx[OF H0(1,2)] measurable_space[OF H_mble,of r] space_prob_algebra[of real_borel] H_Mx
      by (simp add: pair_qbs_prob.intro qbs_probI)
    interpret pps: pair_prob_space "return nat_borel (P r)" "g (P r) r"
      using prob_space_return[of "P r" nat_borel]
      by(simp add: pair_prob_space_def pair_sigma_finite_def prob_space_imp_sigma_finite)
    have [measurable_cong]: "sets (return nat_borel (P r)) = sets nat_borel"
                            "sets (g' r) = sets (nat_borel ⨂M real_borel)"
      using measurable_space[OF g'_mble,of r] space_prob_algebra by auto
    show "qbs_prob_space (X, α (P r), g (P r) r) = qbs_prob_space (X, α'', g'' r)"
    proof(rule pqp.qbs_prob_space_eq4)
      fix f
      assume [measurable]:"f ∈ qbs_to_measure X  →M ennreal_borel"
      show "(∫+ x. f (α (P r) x) ∂g (P r) r) = (∫+ x. f (α'' x) ∂g'' r)"
           (is "?lhs = ?rhs")
      proof -
        have "?lhs = (∫+s. f (α' ((P r),s)) ∂ (g (P r) r))"
          by(simp add: α'_def)
        also have "... = (∫+s. (∫+i. f (α' (i, s)) ∂ (return nat_borel (P r)))  ∂ (g (P r) r))"
          by(auto intro!: nn_integral_cong simp: nn_integral_return[of "P r" nat_borel])
        also have "... = (∫+k. (f ∘ α') k ∂ ((return nat_borel (P r)) ⨂M (g (P r) r)))"
          by(auto intro!: pps.nn_integral_snd)
        also have "... = (∫+k. f (α' k) ∂ (g' r))"
          by(simp add: g'_def)
        also have "... = (∫+x. f x ∂ (distr (g' r) (qbs_to_measure X) α'))"
          by(simp add: nn_integral_distr)
        also have "... = (∫+x. f x ∂ (distr (g'' r) (qbs_to_measure X) α''))"
          by(simp add: distr_distr comp_def g''_def α''_def)
        also have "... = ?rhs"
          by(simp add: nn_integral_distr)
        finally show ?thesis .
      qed
    qed simp
  qed

  have "∀r. Fi (P r) r = qbs_prob_space (X, α'', g'' r)"
    by (metis H_equiv LHS)
  thus "(λr. Fi (P r) r) ∈ monadP_qbs_MPx X"
    using H_mble H_Mx by(auto simp add: monadP_qbs_MPx_def in_MPx_def)
qed

lemma monadP_qbs_correct: "Rep_quasi_borel (monadP_qbs X) = (monadP_qbs_Px X, monadP_qbs_MPx X)"
  by(auto intro!: Abs_quasi_borel_inverse monadP_qbs_f simp: monadP_qbs_closed2 monadP_qbs_closed1 monadP_qbs_closed3 monadP_qbs_def)

lemma monadP_qbs_space[simp] : "qbs_space (monadP_qbs X) = monadP_qbs_Px X"
  by(simp add: qbs_space_def monadP_qbs_correct)

lemma monadP_qbs_Mx[simp] : "qbs_Mx (monadP_qbs X) = monadP_qbs_MPx X"
  by(simp add: qbs_Mx_def monadP_qbs_correct)

lemma monadP_qbs_empty_iff:
 "qbs_space X = {} ⟷ qbs_space (monadP_qbs X) = {}"
proof auto
  fix x
  assume 1:"qbs_space X = {}"
           "x ∈ monadP_qbs_Px X"
  then obtain α μ where "qbs_prob X α μ"
    using rep_monadP_qbs_Px by blast
  thus False
    using empty_quasi_borel_iff[of X] qbs_empty_not_qbs_prob[of α μ] 1(1)
    by auto
next
  fix x
  assume 1:"monadP_qbs_Px X = {}"
           "x ∈ qbs_space X"
  then interpret qp: qbs_prob X "λr. x" "return real_borel 0"
    by(auto intro!: qbs_probI prob_space_return)
  have "qbs_prob_space (X,λr. x,return real_borel 0) ∈ monadP_qbs_Px X"
    by(simp add: monadP_qbs_Px_def)
  thus False
    by(simp add: 1)
qed

text ‹ If ‹β ∈ MPx›, there exists ‹X› ‹α› ‹g› s.t.‹β r = [X,α,g r]›.
       We define a function which picks ‹X› ‹α› ‹g› from ‹β ∈ MPx›.›
definition rep_monadP_qbs_MPx :: "(real ⇒ 'a qbs_prob_space) ⇒ 'a quasi_borel × (real ⇒ 'a) × (real ⇒ real measure)" where
"rep_monadP_qbs_MPx β ≡ let X = qbs_prob_space_qbs (β undefined);
                            αg = (SOME k. (fst k) ∈ qbs_Mx X ∧ (snd k) ∈ real_borel →M prob_algebra real_borel
                                          ∧ β = (λr. qbs_prob_space (X,fst k,snd k r)))
                         in (X,αg)"

lemma qbs_prob_measure_measurable[measurable]:
 "qbs_prob_measure ∈ qbs_to_measure (monadP_qbs (X :: 'a quasi_borel)) →M prob_algebra (qbs_to_measure X)"
proof(rule qbs_morphism_dest,rule qbs_morphismI,simp)
  fix β
  assume "β ∈ monadP_qbs_MPx X"
  then obtain α g where hb:
  "α ∈ qbs_Mx X" "β = (λr. qbs_prob_space (X, α, g r))"
   and g[measurable]: "g ∈ real_borel →M prob_algebra real_borel"  
    using in_MPx.rep_inMPx[of X β] monadP_qbs_MPx_def by blast
  have "qbs_prob_measure ∘ β = (λr. distr (g r) (qbs_to_measure X) α)"
  proof 
    fix r
    interpret qp : qbs_prob X α "g r"
      using qbs_prob_MPx[OF hb(1) g]  by simp
    show "(qbs_prob_measure ∘ β) r = distr (g r) (qbs_to_measure X) α"
      by(simp add: hb(2))
  qed
  also have "... ∈ real_borel →M prob_algebra (qbs_to_measure X) "
    using hb by simp
  finally show "qbs_prob_measure ∘ β ∈ real_borel →M prob_algebra (qbs_to_measure X)" .
qed

lemma qbs_l_inj:
  "inj_on qbs_prob_measure (monadP_qbs_Px X)"
  apply standard
  apply (unfold monadP_qbs_Px_def)
  apply simp
  apply transfer
  apply (auto simp: qbs_prob_eq_def qbs_prob_t_measure_def)
  done

lemma qbs_prob_measure_measurable'[measurable]:
 "qbs_prob_measure ∈ qbs_to_measure (monadP_qbs (X :: 'a quasi_borel)) →M subprob_algebra (qbs_to_measure X)"
  by(auto simp: measurable_prob_algebraD)

subsubsection ‹ Return ›
definition qbs_return :: "['a quasi_borel, 'a] ⇒ 'a qbs_prob_space" where
"qbs_return X x ≡ qbs_prob_space (X,λr. x,Eps real_distribution)"

lemma(in real_distribution) qbs_return_qbs_prob:
  assumes "x ∈ qbs_space X"
  shows "qbs_prob X (λr. x) M"
  using assms 
  by(simp add: qbs_prob_def in_Mx_def real_distribution_axioms)

lemma(in real_distribution) qbs_return_computation :
  assumes "x ∈ qbs_space X"
  shows "qbs_return X x = qbs_prob_space (X,λr. x,M)"
  unfolding qbs_return_def
proof(rule someI2[where a=M])
  fix N
  assume "real_distribution N"
  then interpret pqp: pair_qbs_prob X "λr. x" N X "λr. x" M
    by(simp_all add: pair_qbs_prob_def real_distribution_axioms real_distribution.qbs_return_qbs_prob[OF _ assms])
  show "qbs_prob_space (X, λr. x, N) = qbs_prob_space (X, λr. x, M)"
    by(auto intro!: pqp.qbs_prob_space_eq simp: distr_const[of x "qbs_to_measure X"] assms)
qed (rule real_distribution_axioms)

lemma qbs_return_morphism:
  "qbs_return X ∈ X →Q monadP_qbs X"
proof -
  interpret rr : real_distribution "return real_borel 0"
    by(simp add: real_distribution_def real_distribution_axioms_def prob_space_return)
  show ?thesis
  proof(rule qbs_morphismI,simp)
    fix α
    assume h:"α ∈ qbs_Mx X"
    then have h':"⋀l:: real. α l ∈ qbs_space X"
      by auto
    have "⋀l. (qbs_return X ∘ α) l = qbs_prob_space (X, α, return real_borel l)"
    proof -
      fix l
      interpret pqp: pair_qbs_prob X "λr. α l" "return real_borel 0" X α "return real_borel l"
        using h' by(simp add: pair_qbs_prob_def qbs_prob_def in_Mx_def h real_distribution_def prob_space_return real_distribution_axioms_def)
      have "(qbs_return X ∘ α) l = qbs_prob_space (X,λr. α l,return real_borel 0)"
        using rr.qbs_return_computation[OF h'[of l]] by simp
      also have "... = qbs_prob_space (X, α, return real_borel l)"
        by(auto intro!: pqp.qbs_prob_space_eq simp: distr_return)
      finally show "(qbs_return X ∘ α) l = qbs_prob_space (X, α, return real_borel l)" .
    qed
    thus "qbs_return X ∘ α ∈ monadP_qbs_MPx X"
      by(auto intro!: bexI[where x="α"] bexI[where x="λl. return real_borel l"] simp: h  monadP_qbs_MPx_def in_MPx_def)
  qed
qed

lemma qbs_return_morphism':
  assumes "f ∈ X →Q Y"
  shows "(λx. qbs_return Y (f x)) ∈ X →Q monadP_qbs Y"
  using qbs_morphism_comp[OF assms(1) qbs_return_morphism[of Y]]
  by (simp add: comp_def)

subsubsection ‹Bind›
definition qbs_bind :: "'a qbs_prob_space ⇒ ('a ⇒ 'b qbs_prob_space)  ⇒ 'b qbs_prob_space" where
"qbs_bind s f ≡ (let (qbsx,α,μ) = rep_qbs_prob_space s;
                      (qbsy,β,g) = rep_monadP_qbs_MPx (f ∘ α) 
                     in qbs_prob_space (qbsy,β,μ ⤜ g))"

adhoc_overloading Monad_Syntax.bind qbs_bind

lemma(in qbs_prob) qbs_bind_computation:
  assumes"s = qbs_prob_space (X,α,μ)"
         "f ∈ X →Q monadP_qbs Y"
         "β ∈ qbs_Mx Y"
   and [measurable]: "g ∈ real_borel →M prob_algebra real_borel"
      and "(f ∘ α) = (λr. qbs_prob_space (Y,β, g r))"
    shows "qbs_prob Y β (μ ⤜ g)"
          "s ⤜ f = qbs_prob_space (Y,β,μ ⤜ g)"
proof -
  interpret qp_bind: qbs_prob Y β "μ ⤜ g"
    using assms(3,4) space_prob_algebra[of real_borel] measurable_space[OF assms(4)] events_eq_borel measurable_cong_sets[OF events_eq_borel refl,of "subprob_algebra real_borel"] measurable_prob_algebraD[OF assms(4)]
    by(auto intro!: prob_space_bind[of g real_borel] simp: qbs_prob_def in_Mx_def real_distribution_def real_distribution_axioms_def)
  show "qbs_prob Y β (μ ⤜ g)"
    by (rule qp_bind.qbs_prob_axioms)
  show "s ⤜ f = qbs_prob_space (Y, β, μ ⤜ g)"
    apply(simp add: assms(1) qbs_bind_def rep_qbs_prob_space_def qbs_prob_space.rep_def)
    apply(rule someI2[where a= "(X, α, μ)"])
  proof auto
    fix X' α' μ'
    assume h':"(X',α',μ') ∈ Rep_qbs_prob_space (qbs_prob_space (X, α, μ))"
    from if_in_Rep[OF this] interpret pqp1: pair_qbs_prob X α μ X' α' μ'
      by(simp add: pair_qbs_prob_def qbs_prob_axioms)
    have h_eq: "qbs_prob_space (X, α, μ) = qbs_prob_space (X',α',μ')"
      using if_in_Rep(3)[OF h'] by (simp add: qbs_prob_space_eq)
    note [simp] = if_in_Rep(1)[OF h']
    then obtain β' g' where hb':
     "β' ∈ qbs_Mx Y" "g' ∈ real_borel →M prob_algebra real_borel"
       "f ∘ α' = (λr. qbs_prob_space (Y, β', g' r))"
      using in_MPx.rep_inMPx[of Y "f ∘ α'"] qbs_morphismE(3)[OF assms(2),of α'] pqp1.qp2.qbs_prob_axioms[simplified qbs_prob_def in_Mx_def]
      by(auto simp: monadP_qbs_MPx_def)
    note [measurable] = hb'(2)
    have [simp]:"⋀r. qbs_prob_space_qbs (f (α' r)) = Y"
      subgoal for r
        using fun_cong[OF hb'(3)] qbs_prob.qbs_prob_space_qbs_computation[OF qbs_prob_MPx[OF hb'(1,2),of r]]
        by simp
      done
    show "(case rep_monadP_qbs_MPx (λa. f (α' a)) of (qbsy, β, g) ⇒ qbs_prob_space (qbsy, β, μ' ⤜ g)) =
                 qbs_prob_space (Y, β, μ ⤜ g)"
      unfolding rep_monadP_qbs_MPx_def Let_def
    proof(rule someI2[where a="(β',g')"],auto simp: hb'[simplified comp_def])
      fix α'' g''
      assume h'':"α'' ∈ qbs_Mx Y"
                 "g'' ∈ real_borel →M prob_algebra real_borel"
                 "(λr. qbs_prob_space (Y, β', g' r)) = (λr. qbs_prob_space (Y, α'', g'' r))"
      then interpret pqp2: pair_qbs_prob Y α'' "μ' ⤜ g''" Y β "μ ⤜ g"
        using space_prob_algebra[of real_borel] measurable_space[OF h''(2)] events_eq_borel measurable_cong_sets[OF events_eq_borel refl,of "subprob_algebra real_borel"] measurable_prob_algebraD[OF h''(2)] h''(3)
        by (meson pair_qbs_prob_def in_Mx_def pqp1.qp2.real_distribution_axioms prob_algebra_real_prob_measure prob_space_bind' qbs_probI qbs_prob_def qp_bind.qbs_prob_axioms sets_bind')
      note [measurable] = h''(2)
      have [measurable]:"f ∈ qbs_to_measure X →M qbs_to_measure (monadP_qbs Y)"
        using assms(2) l_preserves_morphisms by auto
      show "qbs_prob_space (Y, α'', μ' ⤜ g'') = qbs_prob_space (Y, β, μ ⤜ g)"
      proof(rule pqp2.qbs_prob_space_eq)
        show "distr (μ' ⤜ g'') (qbs_to_measure Y) α'' = distr (μ ⤜ g) (qbs_to_measure Y) β"
             (is "?lhs = ?rhs")
        proof -
          have "?lhs = μ' ⤜ (λx. distr (g'' x) (qbs_to_measure Y) α'')"
            by(auto intro!: distr_bind[where K=real_borel] simp: measurable_prob_algebraD)
          also have "... = μ' ⤜ (λx. qbs_prob_measure (qbs_prob_space (Y,α'',g'' x)))"
            by(auto intro!: bind_cong simp: qbs_prob_MPx[OF h''(1,2)] qbs_prob.qbs_prob_measure_computation)
          also have "... = μ' ⤜ (λx. (qbs_prob_measure  ((f ∘ α') x)))"
            by(simp add: hb'(3) h''(3))
          also have "... = μ' ⤜ (λx. (qbs_prob_measure ∘ f)  (α' x))"
            by(simp add: comp_def)
          also have "... = distr μ' (qbs_to_measure X) α' ⤜ qbs_prob_measure ∘ f"
            by(rule bind_distr[where K="qbs_to_measure Y",symmetric],auto)
          also have "... = distr μ (qbs_to_measure X) α ⤜ qbs_prob_measure ∘ f"
            using pqp1.qbs_prob_space_eq_inverse(1)[OF h_eq]
            by(simp add: qbs_prob_eq_def)
          also have "... = μ ⤜ (λx. (qbs_prob_measure ∘ f)  (α x))"
            by(rule bind_distr[where K="qbs_to_measure Y"],auto)
          also have "... = μ ⤜ (λx. (qbs_prob_measure  ((f ∘ α) x)))"
            by(simp add: comp_def)
          also have "... = μ ⤜ (λx. qbs_prob_measure (qbs_prob_space (Y,β,g x)))"
            by(auto simp: assms(5))
          also have "... = μ ⤜ (λx. distr (g x) (qbs_to_measure Y) β)"
            by(auto intro!: bind_cong simp: qbs_prob_MPx[OF assms(3)] qbs_prob.qbs_prob_measure_computation)
          also have "... = ?rhs"
            by(auto intro!: distr_bind[where K=real_borel,symmetric] simp: measurable_prob_algebraD)
          finally show ?thesis .
        qed
      qed simp
    qed
  qed (rule in_Rep)
qed

lemma qbs_bind_morphism':
  assumes "f ∈ X →Q monadP_qbs Y"
  shows "(λx. x ⤜ f) ∈ monadP_qbs X →Q monadP_qbs Y"
proof(rule qbs_morphismI,simp)
  fix β
  assume "β ∈ monadP_qbs_MPx X"
  then obtain α g where hb:
   "α ∈ qbs_Mx X" "g ∈ real_borel →M prob_algebra real_borel"
   "β = (λr. qbs_prob_space (X, α, g r))"
    using rep_monadP_qbs_MPx by blast
  obtain γ g' where hc:
   "γ ∈ qbs_Mx Y" "g' ∈ real_borel →M prob_algebra real_borel"
   "f ∘ α = (λr. qbs_prob_space (Y, γ, g' r))"
    using rep_monadP_qbs_MPx[of "f ∘ α" Y] qbs_morphismE(3)[OF assms hb(1),simplified]
    by auto
  note [measurable] = hb(2) hc(2)
  show "(λx. x ⤜ f) ∘ β ∈ monadP_qbs_MPx Y"
  proof -
    have "(λx. x ⤜ f) ∘ β = (λr. β r ⤜ f)"
      by auto
    also have "... ∈ monadP_qbs_MPx Y"
      unfolding monadP_qbs_MPx_def in_MPx_def
      by(auto intro!: bexI[where x="γ"] bexI[where x="λr. g r ⤜ g'"] simp: hc(1) hb(3) qbs_prob.qbs_bind_computation[OF qbs_prob_MPx[OF hb(1,2)] _ assms hc])
    finally show ?thesis .
  qed
qed

lemma qbs_return_comp:
  assumes "α ∈ qbs_Mx X"
  shows "(qbs_return X ∘ α) = (λr. qbs_prob_space (X,α,return real_borel r))"
proof
  fix r
  interpret pqp: pair_qbs_prob X "λk. α r" "return real_borel 0" X α "return real_borel r"
    by(simp add: assms qbs_Mx_to_X(2)[OF assms] pair_qbs_prob_def qbs_prob_def in_Mx_def real_distribution_def real_distribution_axioms_def prob_space_return)
  show "(qbs_return X ∘ α) r = qbs_prob_space (X, α, return real_borel r)"
    by(auto intro!: pqp.qbs_prob_space_eq simp: distr_return pqp.qp1.qbs_return_computation qbs_Mx_to_X(2)[OF assms])
qed

lemma qbs_bind_return':
  assumes "x ∈ monadP_qbs_Px X"
  shows "x ⤜ qbs_return X = x"
proof -
  obtain α μ where h1:"qbs_prob X α μ" "x = qbs_prob_space (X, α, μ)"
    using assms rep_monadP_qbs_Px by blast
  then interpret qp: qbs_prob X α μ
    by simp
  show ?thesis
    using qp.qbs_bind_computation[OF h1(2) qbs_return_morphism _ measurable_return_prob_space qbs_return_comp[OF qp.in_Mx]]
    by(simp add: h1(2) bind_return'' prob_space_return qbs_probI)
qed

lemma qbs_bind_return:
  assumes "f ∈ X →Q monadP_qbs Y"
      and "x ∈ qbs_space X"
    shows "qbs_return X x ⤜ f = f x"
proof -
  have "f x ∈ monadP_qbs_Px Y"
    using assms by auto
  then obtain β μ where hf:"qbs_prob Y β μ" "f x = qbs_prob_space (Y, β, μ)"
    using rep_monadP_qbs_Px by blast
  then interpret rd: real_distribution "return real_borel 0"
    by(simp add: qbs_prob_def prob_space_return real_distribution_def real_distribution_axioms_def)
  interpret rd': real_distribution μ
    using hf(1) by(simp add: qbs_prob_def)
  interpret qp: qbs_prob X "λr. x" "return real_borel 0"
    using assms(2) by(auto simp: qbs_prob_def in_Mx_def rd.real_distribution_axioms)
  show ?thesis
    by(auto intro!: qp.qbs_bind_computation(2)[OF rd.qbs_return_computation[OF assms(2)] assms(1) _ measurable_const[of μ],of β,simplified bind_const'[OF rd.prob_space_axioms rd'.subprob_space_axioms]]
              simp: hf[simplified qbs_prob_def in_Mx_def] prob_algebra_real_prob_measure)
qed

lemma qbs_bind_assoc:
  assumes "s ∈ monadP_qbs_Px X"
          "f ∈ X →Q monadP_qbs Y"
      and "g ∈ Y →Q monadP_qbs Z"
   shows "s ⤜ (λx. f x ⤜ g) = (s ⤜ f) ⤜ g"
proof -
  obtain α μ where H0:"qbs_prob X α μ" "s = qbs_prob_space (X, α, μ)"
    using assms rep_monadP_qbs_Px by blast
  then have "f ∘ α ∈ monadP_qbs_MPx Y"
    using assms(2) by(auto simp: qbs_prob_def in_Mx_def)
  from rep_monadP_qbs_MPx[OF this] obtain β g1 where H1:
   "β ∈ qbs_Mx Y" "g1 ∈ real_borel →M prob_algebra real_borel"
   " (f ∘ α) = (λr. qbs_prob_space (Y, β, g1 r))"
    by auto
  hence "g ∘ β ∈ monadP_qbs_MPx Z"
    using assms by(simp add: qbs_morphism_def)
  from rep_monadP_qbs_MPx[OF this] obtain γ g2 where H2:
   "γ ∈ qbs_Mx Z" "g2 ∈ real_borel →M prob_algebra real_borel"
   "(g ∘ β) = (λr. qbs_prob_space (Z, γ, g2 r))"
    by auto
  note [measurable] = H1(2) H2(2)
  interpret rd: real_distribution μ
    using H0(1) by(simp add: qbs_prob_def)
  have LHS: "(s ⤜ f) ⤜ g = qbs_prob_space (Z, γ, μ ⤜ g1 ⤜ g2)"
    by(rule qbs_prob.qbs_bind_computation(2)[OF qbs_prob.qbs_bind_computation[OF H0 assms(2) H1] assms(3) H2])
  have RHS: "s ⤜ (λx. f x ⤜ g) =  qbs_prob_space (Z, γ, μ ⤜ (λx. g1 x ⤜ g2))"
    apply(auto intro!: qbs_prob.qbs_bind_computation[OF H0 qbs_morphism_comp[OF assms(2) qbs_bind_morphism'[OF assms(3)],simplified comp_def]]
                 simp: real_distribution_def real_distribution_axioms_def qbs_prob_def qbs_prob_MPx[OF H2(1,2),simplified qbs_prob_def] sets_bind'[OF measurable_space[OF H1(2)] H2(2)] prob_space_bind'[OF measurable_space[OF H1(2)] H2(2)] measurable_space[OF H2(2)] space_prob_algebra[of real_borel] H2(1))
  proof
    fix r
    show "((λx. f x ⤜ g) ∘ α) r = qbs_prob_space (Z, γ, g1 r ⤜ g2)" (is "?lhs = ?rhs") for r
      by(auto intro!: qbs_prob.qbs_bind_computation(2)[of Y β]
                simp: qbs_prob_MPx[OF H1(1,2),of r] assms(3) H2 fun_cong[OF H1(3),simplified comp_def])
  qed
  have ba: "μ ⤜ g1 ⤜ g2 = μ ⤜ (λx. g1 x ⤜ g2)"
    by(auto intro!: bind_assoc[where N=real_borel and R=real_borel] simp: measurable_prob_algebraD)
  show ?thesis
    by(simp add: LHS RHS ba)
qed

lemma qbs_bind_cong:
  assumes "s ∈ monadP_qbs_Px X"
          "⋀x. x ∈ qbs_space X ⟹ f x = g x"
      and "f ∈ X →Q monadP_qbs Y"
    shows "s ⤜ f = s ⤜ g"
proof -
  obtain α μ where h0:
  "qbs_prob X α μ"  "s = qbs_prob_space (X, α, μ)"
    using rep_monadP_qbs_Px[OF assms(1)] by auto
  then have "f ∘ α ∈ monadP_qbs_MPx Y"
    using assms(3) h0(1) by(auto simp: qbs_prob_def in_Mx_def)
  from rep_monadP_qbs_MPx[OF this] obtain γ k where h1:
   "γ ∈ qbs_Mx Y" "k ∈ real_borel →M prob_algebra real_borel"
   "(f ∘ α) = (λr. qbs_prob_space (Y, γ, k r))"
    by auto
  have hg:"g ∈ X →Q monadP_qbs Y"
    using qbs_morphism_cong[OF assms(2,3)] by simp
  have hgs: "f ∘ α = g ∘ α"
    using h0(1) assms(2) by(force simp: qbs_prob_def in_Mx_def)

  show ?thesis
    by(simp add: qbs_prob.qbs_bind_computation(2)[OF h0 assms(3) h1]
                 qbs_prob.qbs_bind_computation(2)[OF h0 hg h1[simplified hgs]])
qed

subsubsection ‹ The Functorial Action $P(f)$›
definition monadP_qbs_Pf :: "['a quasi_borel, 'b quasi_borel,'a ⇒ 'b,'a qbs_prob_space] ⇒ 'b qbs_prob_space" where
"monadP_qbs_Pf _ Y f sx ≡ sx ⤜ qbs_return Y ∘ f"

lemma monadP_qbs_Pf_morphism:
  assumes "f ∈ X →Q Y"
  shows "monadP_qbs_Pf X Y f ∈ monadP_qbs X →Q monadP_qbs Y"
  unfolding monadP_qbs_Pf_def
  by(rule qbs_bind_morphism'[OF qbs_morphism_comp[OF assms qbs_return_morphism]])

lemma(in qbs_prob) monadP_qbs_Pf_computation:
  assumes "s = qbs_prob_space (X,α,μ)"
      and "f ∈ X →Q Y"
    shows "qbs_prob Y (f ∘ α) μ"
      and "monadP_qbs_Pf X Y f s = qbs_prob_space (Y,f ∘ α,μ)"
   by(auto intro!: qbs_bind_computation[OF assms(1) qbs_morphism_comp[OF assms(2) qbs_return_morphism],of "f ∘ α" "return real_borel" ,simplified bind_return''[OF M_is_borel]]
             simp: monadP_qbs_Pf_def qbs_return_comp[OF qbs_morphismE(3)[OF assms(2) in_Mx],simplified comp_assoc[symmetric]] qbs_morphismE(3)[OF assms(2) in_Mx] prob_space_return)

text ‹ We show that P is a functor i.e. P preserves identity and composition.›
lemma monadP_qbs_Pf_id:
  assumes "s ∈ monadP_qbs_Px X"
  shows "monadP_qbs_Pf X X id s = s"
  using qbs_bind_return'[OF assms] by(simp add: monadP_qbs_Pf_def)

lemma monadP_qbs_Pf_comp:
  assumes "s ∈ monadP_qbs_Px X"
          "f ∈ X →Q Y"
      and "g ∈ Y →Q Z" 
    shows "((monadP_qbs_Pf Y Z g) ∘ (monadP_qbs_Pf X Y f)) s = monadP_qbs_Pf X Z (g ∘ f) s"
proof -
  obtain α μ where h:
  "qbs_prob X α μ" "s = qbs_prob_space (X, α, μ)"
    using rep_monadP_qbs_Px[OF assms(1)] by auto
  hence "qbs_prob Y (f ∘ α) μ"
        "monadP_qbs_Pf X Y f s = qbs_prob_space (Y,f ∘ α,μ)"
    using qbs_prob.monadP_qbs_Pf_computation[OF _ _ assms(2)] by auto
  from qbs_prob.monadP_qbs_Pf_computation[OF this assms(3)] qbs_prob.monadP_qbs_Pf_computation[OF h qbs_morphism_comp[OF assms(2,3)]]
  show ?thesis
    by(simp add: comp_assoc)
qed

subsubsection ‹ Join ›
definition qbs_join :: "'a qbs_prob_space qbs_prob_space ⇒ 'a qbs_prob_space" where
"qbs_join ≡ (λsst. sst ⤜ id)"

lemma qbs_join_morphism:
  "qbs_join ∈ monadP_qbs (monadP_qbs X) →Q monadP_qbs X"
  by(simp add: qbs_join_def qbs_bind_morphism'[OF qbs_morphism_ident])

lemma qbs_join_computation:
  assumes "qbs_prob (monadP_qbs X) β μ"
          "ssx = qbs_prob_space (monadP_qbs X,β,μ)"
          "α ∈ qbs_Mx X"
          "g ∈ real_borel →M prob_algebra real_borel"
      and "β =(λr.  qbs_prob_space (X,α,g r))"
    shows "qbs_prob X α (μ ⤜ g)" "qbs_join ssx = qbs_prob_space (X,α, μ ⤜ g)"
  using qbs_prob.qbs_bind_computation[OF assms(1,2) qbs_morphism_ident assms(3,4)]
  by(auto simp: assms(5) qbs_join_def)

subsubsection ‹ Strength ›
definition qbs_strength :: "['a quasi_borel,'b quasi_borel,'a × 'b qbs_prob_space] ⇒ ('a × 'b) qbs_prob_space" where
"qbs_strength W X = (λ(w,sx). let (_,α,μ) = rep_qbs_prob_space sx
                         in qbs_prob_space (W ⨂Q X, λr. (w,α r), μ))"

lemma(in qbs_prob) qbs_strength_computation:
  assumes "w ∈ qbs_space W"
      and "sx = qbs_prob_space (X,α,μ)"
    shows "qbs_prob (W ⨂Q X) (λr. (w,α r)) μ"
          "qbs_strength W X (w,sx) = qbs_prob_space (W ⨂Q X, λr. (w,α r), μ)"
proof -
  interpret qp1: qbs_prob "W ⨂Q X" "λr. (w,α r)" μ
    by(auto intro!: qbs_probI simp: assms(1) pair_qbs_Mx_def comp_def)
  show "qbs_prob (W ⨂Q X) (λr. (w,α r)) μ"
       "qbs_strength W X (w,sx) = qbs_prob_space (W ⨂Q X, λr. (w,α r), μ)"
     apply(simp_all add: qp1.qbs_prob_axioms qbs_strength_def rep_qbs_prob_space_def qbs_prob_space.rep_def)
    apply(rule someI2[where a="(X,α,μ)"])
  proof(auto simp: in_Rep assms(2))
    fix X' α' μ'
    assume h:"(X',α',μ') ∈ Rep_qbs_prob_space (qbs_prob_space (X, α, μ))"
    from if_in_Rep(1,2)[OF this] interpret pqp: pair_qbs_prob "W ⨂Q X" "λr. (w, α' r)" μ' "W ⨂Q X" "λr. (w,α r)" μ
      by(simp add: pair_qbs_prob_def qp1.qbs_prob_axioms)
       (auto intro!: qbs_probI simp: pair_qbs_Mx_def comp_def assms(1) qbs_prob_def in_Mx_def)
    note [simp] = qbs_prob_eq2_dest[OF if_in_Rep(3)[OF h,simplified qbs_prob_eq_equiv12]]
    show "qbs_prob_space (W ⨂Q X, λr. (w, α' r), μ') = qbs_prob_space (W ⨂Q X, λr. (w, α r), μ)"
    proof(rule pqp.qbs_prob_space_eq2)
      fix f
      assume "f ∈ qbs_to_measure (W ⨂Q X) →M real_borel"
      note qbs_morphism_dest[OF qbs_morphismE(2)[OF curry_preserves_morphisms[OF qbs_morphism_measurable_intro[OF this]] assms(1),simplified]]
      show "(∫y. f ((λr. (w, α' r)) y) ∂ μ') = (∫y. f ((λr. (w, α r)) y) ∂ μ)"
           (is "?lhs = ?rhs")
      proof -
        have "?lhs = (∫y. curry f w (α' y) ∂ μ')" by auto
        also have "... = (∫y. curry f w (α y) ∂ μ)"
          by(rule qbs_prob_eq2_dest(4)[OF if_in_Rep(3)[OF h,simplified qbs_prob_eq_equiv12],symmetric]) fact
        also have "... = ?rhs" by auto
        finally show ?thesis .
      qed
    qed simp
  qed
qed

lemma qbs_strength_natural:
  assumes "f ∈ X →Q X'"
          "g ∈ Y →Q Y'"
          "x ∈ qbs_space X"
      and "sy ∈ monadP_qbs_Px Y"
    shows "(monadP_qbs_Pf (X ⨂Q Y) (X' ⨂Q Y') (map_prod f g) ∘ qbs_strength X Y) (x,sy) = (qbs_strength X' Y' ∘ map_prod f (monadP_qbs_Pf Y Y' g)) (x,sy)"
          (is "?lhs = ?rhs")
proof -
  obtain β ν where hy:
   "qbs_prob Y β ν" "sy = qbs_prob_space (Y,β,ν)"
    using rep_monadP_qbs_Px[OF assms(4)] by auto
  have "qbs_prob (X ⨂Q Y) (λr. (x, β r)) ν"
       "qbs_strength X Y (x, sy) = qbs_prob_space (X ⨂Q Y, λr. (x, β r), ν)"
    using qbs_prob.qbs_strength_computation[OF hy(1) assms(3) hy(2)] by auto
  hence LHS:"?lhs = qbs_prob_space (X' ⨂Q Y',map_prod f g ∘ (λr. (x, β r)),ν)"
    by(simp add: qbs_prob.monadP_qbs_Pf_computation[OF _ _ qbs_morphism_map_prod[OF assms(1,2)]])

  have "map_prod f (monadP_qbs_Pf Y Y' g) (x,sy) = (f x,qbs_prob_space (Y',g ∘ β,ν))"
       "qbs_prob Y' (g ∘ β) ν"
    by(auto simp: qbs_prob.monadP_qbs_Pf_computation[OF hy assms(2)])
  hence RHS:"?rhs = qbs_prob_space (X' ⨂Q Y',λr. (f x, (g ∘ β) r),ν)"
    using qbs_prob.qbs_strength_computation[OF _ _ refl,of Y' "g ∘ β" ν "f x" X'] assms(1,3)
    by auto

  show "?lhs = ?rhs"
    unfolding LHS RHS
    by(simp add: comp_def)
qed

lemma qbs_strength_ab_r:
  assumes "α ∈ qbs_Mx X"
          "β ∈ monadP_qbs_MPx Y"
          "γ ∈ qbs_Mx Y"
 and [measurable]:"g ∈ real_borel →M prob_algebra real_borel"
      and "β = (λr. qbs_prob_space (Y,γ,g r))"
    shows "qbs_prob (X ⨂Q Y) (map_prod α γ ∘ real_real.g) (distr (return real_borel r ⨂M g r) real_borel real_real.f)"         
          "qbs_strength X Y (α r, β r) = qbs_prob_space (X ⨂Q Y, map_prod α γ ∘ real_real.g, distr (return real_borel r ⨂M g r) real_borel real_real.f)"
proof -
  have [measurable_cong]: "sets (g r) = sets real_borel"
                          "sets (return real_borel r) = sets real_borel"
    using measurable_space[OF assms(4),of r]
    by(simp_all add: space_prob_algebra)
  interpret qp: qbs_prob "X ⨂Q Y" "map_prod α γ ∘ real_real.g" "distr (return real_borel r ⨂M g r) real_borel real_real.f"
  proof(auto intro!: qbs_probI)
    show "map_prod α γ ∘ real_real.g ∈ pair_qbs_Mx X Y"
      using qbs_closed1_dest[OF assms(1)] qbs_closed1_dest[OF assms(3)]
      by(auto simp: comp_def qbs_prob_def in_Mx_def pair_qbs_Mx_def)
  next
    show "prob_space (distr (return real_borel r ⨂M g r) real_borel real_real.f) "
      using measurable_space[OF assms(4),of r]
      by(auto intro!: prob_space.prob_space_distr simp: prob_algebra_real_prob_measure prob_space_pair prob_space_return real_distribution.axioms(1))
  qed
  interpret pqp: pair_qbs_prob "X ⨂Q Y" "λl. (α r, γ l)" "g r" "X ⨂Q Y" "map_prod α γ ∘ real_real.g" "distr (return real_borel r ⨂M g r) real_borel real_real.f"
    by(simp add: qbs_prob.qbs_strength_computation[OF qbs_prob_MPx[OF assms(3,4)] qbs_Mx_to_X(2)[OF assms(1)] fun_cong[OF assms(5)],of r] pair_qbs_prob_def qp.qbs_prob_axioms)
  have [measurable]: "map_prod α γ ∈ real_borel ⨂M real_borel →M qbs_to_measure (X ⨂Q Y)"
  proof -
    have "map_prod α γ ∈ ℝQ ⨂Q ℝQ →Q X ⨂Q Y"
      using assms(1,3) by(auto intro!: qbs_morphism_map_prod simp: qbs_Mx_is_morphisms)
    hence "map_prod α γ ∈ qbs_to_measure (ℝQ ⨂Q ℝQ) →M qbs_to_measure (X ⨂Q Y)"
      using l_preserves_morphisms by auto
    thus ?thesis
      by simp
  qed
  hence [measurable]:"(λl. (α r, γ l)) ∈ real_borel →M qbs_to_measure (X ⨂Q Y)"
    using pqp.qp1.in_Mx qbs_Mx_are_measurable by blast

  show "qbs_prob (X ⨂Q Y) (map_prod α γ ∘ real_real.g) (distr (return real_borel r ⨂M g r) real_borel real_real.f)"         
       "qbs_strength X Y (α r, β r) = qbs_prob_space (X ⨂Q Y, map_prod α γ ∘ real_real.g, distr (return real_borel r ⨂M g r) real_borel real_real.f)"
     apply(simp_all add: qp.qbs_prob_axioms qbs_prob.qbs_strength_computation(2)[OF qbs_prob_MPx[OF assms(3,4)] qbs_Mx_to_X(2)[OF assms(1)] fun_cong[OF assms(5)],of r])
  proof(rule pqp.qbs_prob_space_eq)
    show "distr (g r) (qbs_to_measure (X ⨂Q Y)) (λl. (α r, γ l)) = distr (distr (return real_borel r ⨂M g r) real_borel real_real.f) (qbs_to_measure (X ⨂Q Y)) (map_prod α γ ∘ real_real.g)"
         (is "?lhs = ?rhs")
    proof -
      have "?lhs = distr (g r) (qbs_to_measure (X ⨂Q Y)) (map_prod α γ ∘ Pair r)"
        by(simp add: comp_def)
      also have "... = distr (distr (g r) (real_borel ⨂M real_borel) (Pair r)) (qbs_to_measure (X ⨂Q Y)) (map_prod α γ)"
        by(auto intro!: distr_distr[symmetric])
      also have "... = distr (return real_borel r ⨂M g r) (qbs_to_measure (X ⨂Q Y)) (map_prod α γ)"
      proof -
        have "return real_borel r ⨂M g r = distr (g r) (real_borel ⨂M real_borel) (λl. (r,l))"
        proof(auto intro!: measure_eqI)
          fix A
          assume h':"A ∈ sets (real_borel ⨂M real_borel)"
          show "emeasure (return real_borel r ⨂M g r) A = emeasure (distr (g r) (real_borel ⨂M real_borel) (Pair r)) A"
                (is "?lhs' = ?rhs'")
          proof -
            have "?lhs' = ∫+ x. emeasure (g r) (Pair x -` A) ∂return real_borel r"
              by(auto intro!: pqp.qp1.emeasure_pair_measure_alt simp: h')
            also have "... = emeasure (g r) (Pair r -` A)"
              by(auto intro!: nn_integral_return pqp.qp1.measurable_emeasure_Pair simp: h')
            also have "... = ?rhs'"
              by(simp add: emeasure_distr[OF _ h'])
            finally show ?thesis .
          qed
        qed
        thus ?thesis by simp
      qed
      also have "... = ?rhs"
        by(rule distr_distr[of "map_prod α γ ∘ real_real.g" real_borel "qbs_to_measure (X ⨂Q Y)" real_real.f "return real_borel r ⨂M g r",simplified comp_assoc,simplified,symmetric])
      finally show ?thesis .
    qed
  qed simp
qed


lemma qbs_strength_morphism:
 "qbs_strength X Y ∈ X ⨂Q monadP_qbs Y →Q monadP_qbs (X ⨂Q Y)"
proof(rule pair_qbs_morphismI,simp)
  fix α β
  assume h:"α ∈ qbs_Mx X"
           "β ∈ monadP_qbs_MPx Y"
  then obtain γ g where hb:
    "γ ∈ qbs_Mx Y" "g ∈ real_borel →M prob_algebra real_borel"
    "β = (λr. qbs_prob_space (Y, γ, g r))"
    using rep_monadP_qbs_MPx[of β] by blast
  note [measurable] = hb(2)
  show "qbs_strength X Y ∘ (λr. (α r, β r)) ∈ monadP_qbs_MPx (X ⨂Q Y)"
    using qbs_strength_ab_r[OF h hb]
    by(auto intro!: bexI[where x="map_prod α γ ∘ real_real.g"] bexI[where x="λr. distr (return real_borel r ⨂M g r) real_borel real_real.f"]
              simp: monadP_qbs_MPx_def in_MPx_def qbs_prob_def in_Mx_def)
qed

lemma qbs_bind_morphism'':
 "(λ(f,x). x ⤜ f) ∈ exp_qbs X (monadP_qbs Y) ⨂Q (monadP_qbs X) →Q (monadP_qbs Y)"
proof(rule qbs_morphism_cong[of _ "qbs_join ∘ (monadP_qbs_Pf (exp_qbs X (monadP_qbs Y) ⨂Q X) (monadP_qbs Y) qbs_eval) ∘ (qbs_strength (exp_qbs X (monadP_qbs Y)) X)"], auto)
  fix f
  fix sx
  assume h:"f ∈ X →Q monadP_qbs Y"
           "sx ∈ monadP_qbs_Px X"
  then obtain α μ where h0:"qbs_prob X α μ" "sx = qbs_prob_space (X, α, μ)"
    using rep_monadP_qbs_Px[of sx X] by auto
  hence "f ∘ α ∈ monadP_qbs_MPx Y"
    using h(1) by(auto simp: qbs_prob_def in_Mx_def)
  then obtain β g where h1: 
  "β ∈ qbs_Mx Y" "g ∈ real_borel →M prob_algebra real_borel"
  "(f ∘ α) = (λr. qbs_prob_space (Y, β, g r))"
    using rep_monadP_qbs_MPx[of "f ∘ α" Y] by blast

  show "qbs_join (monadP_qbs_Pf (exp_qbs X (monadP_qbs Y) ⨂Q X) (monadP_qbs Y) qbs_eval (qbs_strength (exp_qbs X (monadP_qbs Y)) X (f, sx))) =
           sx ⤜ f"
    by(simp add: qbs_join_computation[OF qbs_prob.monadP_qbs_Pf_computation[OF qbs_prob.qbs_strength_computation[OF h0(1) _ h0(2),of f "exp_qbs X (monadP_qbs Y)"] qbs_eval_morphism] h1(1,2),simplified qbs_eval_def comp_def,simplified,OF h(1) h1(3)[simplified comp_def]] qbs_prob.qbs_bind_computation[OF h0 h(1) h1])
next
  show "qbs_join ∘  monadP_qbs_Pf (exp_qbs X (monadP_qbs Y) ⨂Q X) (monadP_qbs Y) qbs_eval ∘ qbs_strength (exp_qbs X (monadP_qbs Y)) X ∈ exp_qbs X (monadP_qbs Y) ⨂Q monadP_qbs X →Q monadP_qbs Y"
    using qbs_join_morphism monadP_qbs_Pf_morphism[OF qbs_eval_morphism]
    by(auto intro!: qbs_morphism_comp simp: qbs_strength_morphism)
qed

lemma qbs_bind_morphism''':
  "(λf x. x ⤜ f) ∈ exp_qbs X (monadP_qbs Y) →Q exp_qbs (monadP_qbs X) (monadP_qbs Y)"
  using qbs_bind_morphism'' curry_preserves_morphisms[of "λ(f, x). qbs_bind x f"]
  by fastforce

lemma qbs_bind_morphism:
  assumes "f ∈ X →Q monadP_qbs Y"
      and "g ∈ X →Q exp_qbs Y (monadP_qbs Z)"
    shows "(λx. f x ⤜ g x) ∈ X →Q monadP_qbs Z"
  using qbs_morphism_comp[OF qbs_morphism_tuple[OF assms(2,1)] qbs_bind_morphism'']
  by(simp add: comp_def)

lemma qbs_bind_morphism'''':
  assumes "x ∈ monadP_qbs_Px X"
  shows "(λf. x ⤜ f) ∈ exp_qbs X (monadP_qbs Y) →Q monadP_qbs Y"
  by(rule qbs_morphismE(2)[OF arg_swap_morphism[OF qbs_bind_morphism'''],simplified,OF assms])

lemma qbs_strength_law1:
  assumes "x ∈ qbs_space (unit_quasi_borel ⨂Q monadP_qbs X)"
  shows "snd x = (monadP_qbs_Pf (unit_quasi_borel ⨂Q X) X snd ∘ qbs_strength unit_quasi_borel X) x"
proof -
  obtain α μ where h:
   "qbs_prob X α μ" "(snd x) = qbs_prob_space (X, α, μ)"
    using rep_monadP_qbs_Px[of "snd x" X] assms by auto
  have [simp]: "((),snd x) = x"
    using SigmaE assms by auto
  show ?thesis
    using qbs_prob.monadP_qbs_Pf_computation[OF qbs_prob.qbs_strength_computation[OF h(1) _ h(2),of "fst x" "unit_quasi_borel",simplified] snd_qbs_morphism]
    by(simp add: h(2) comp_def)
qed

lemma qbs_strength_law2:
  assumes "x ∈ qbs_space ((X ⨂Q Y) ⨂Q monadP_qbs Z)"
  shows "(qbs_strength X (Y ⨂Q Z) ∘ (map_prod id (qbs_strength Y Z)) ∘ (λ((x,y),z). (x,(y,z)))) x =
         (monadP_qbs_Pf ((X ⨂Q Y) ⨂Q Z) (X ⨂Q (Y ⨂Q Z)) (λ((x,y),z). (x,(y,z))) ∘ qbs_strength (X ⨂Q Y) Z) x"
         (is "?lhs = ?rhs")
proof -
  obtain α μ where h:
   "qbs_prob Z α μ" "snd x = qbs_prob_space (Z, α, μ)"
    using rep_monadP_qbs_Px[of "snd x" Z] assms by auto
  have "?lhs = qbs_prob_space (X ⨂Q Y ⨂Q Z, λr. (fst (fst x), snd (fst x), α r), μ)"
    using assms  qbs_prob.qbs_strength_computation[OF h(1) _ h(2),of "snd (fst x)" Y]
    by(auto intro!: qbs_prob.qbs_strength_computation)
  also have "... = ?rhs"
    using qbs_prob.monadP_qbs_Pf_computation[OF qbs_prob.qbs_strength_computation[OF h(1) _ h(2),of "fst x" "X ⨂Q Y"] qbs_morphism_pair_assoc1] assms
    by(auto simp: comp_def)
  finally show ?thesis .
qed

lemma qbs_strength_law3:
  assumes "x ∈ qbs_space (X ⨂Q Y)"
  shows "qbs_return (X ⨂Q Y) x = (qbs_strength X Y ∘ (map_prod id (qbs_return Y))) x"
proof -
  interpret qp: qbs_prob Y "λr. snd x" "return real_borel 0"
    using assms by(auto intro!: qbs_probI simp: prob_space_return)
  show ?thesis
    using qp.qbs_strength_computation[OF _ qp.qbs_return_computation[of "snd x" Y],of "fst x" X] assms
    by(auto simp: qp.qbs_return_computation[OF assms])
qed

lemma qbs_strength_law4:
  assumes "x ∈ qbs_space (X ⨂Q monadP_qbs (monadP_qbs Y))"
  shows "(qbs_strength X Y ∘ map_prod id qbs_join) x = (qbs_join ∘ monadP_qbs_Pf (X ⨂Q monadP_qbs Y) (monadP_qbs (X ⨂Q Y))(qbs_strength X Y) ∘ qbs_strength X (monadP_qbs Y)) x"
        (is "?lhs = ?rhs")
proof -
  obtain β μ where h0:
  "qbs_prob (monadP_qbs Y) β μ" "snd x = qbs_prob_space (monadP_qbs Y, β, μ)"
    using rep_monadP_qbs_Px[of "snd x" "monadP_qbs Y"] assms by auto
  then obtain γ g where h1:
   "γ ∈ qbs_Mx Y" "g ∈ real_borel →M prob_algebra real_borel"
   "β = (λr. qbs_prob_space (Y, γ, g r))"
    using rep_monadP_qbs_MPx[of β Y] by(auto simp: qbs_prob_def in_Mx_def)
  have "?lhs = qbs_prob_space (X ⨂Q Y, λr. (fst x, γ r), μ ⤜ g)"
    using qbs_prob.qbs_strength_computation[OF qbs_join_computation(1)[OF h0 h1] _ qbs_join_computation(2)[OF h0 h1],of "fst x" X] assms
    by auto
  also have "... = ?rhs"
  proof -
    have "qbs_strength X Y ∘ (λr. (fst x, β r)) = (λr. qbs_prob_space (X ⨂Q Y, λr. (fst x, γ r), g r))"
    proof
      show "(qbs_strength X Y ∘ (λr. (fst x, β r))) r = qbs_prob_space (X ⨂Q Y, λr. (fst x, γ r), g r)" for r
        using qbs_prob.qbs_strength_computation(2)[OF qbs_prob_MPx[OF h1(1,2),of r] _ fun_cong[OF h1(3)],of "fst x" X] assms
        by auto
    qed
    thus ?thesis
      using qbs_join_computation(2)[OF qbs_prob.monadP_qbs_Pf_computation[OF qbs_prob.qbs_strength_computation[OF h0(1) _ h0(2),of "fst x" X] qbs_strength_morphism] _ h1(2),of "λr. (fst x, γ r)",symmetric] assms h1(1)
      by(auto simp: pair_qbs_Mx_def comp_def)
  qed
  finally show ?thesis .
qed


lemma qbs_return_Mxpair:
  assumes "α ∈ qbs_Mx X"
      and "β ∈ qbs_Mx Y"
    shows "qbs_return (X ⨂Q Y) (α r, β k) = qbs_prob_space (X ⨂Q Y,map_prod α β ∘ real_real.g, distr (return real_borel r ⨂M return real_borel k) real_borel real_real.f)"
          "qbs_prob (X ⨂Q Y) (map_prod α β ∘ real_real.g) (distr (return real_borel r ⨂M return real_borel k) real_borel real_real.f)"
proof -
  note [measurable_cong] = sets_return[of real_borel]
  interpret qp: qbs_prob "X ⨂Q Y" "map_prod α β ∘ real_real.g" "distr (return real_borel r ⨂M return real_borel k) real_borel real_real.f"
    using qbs_closed1_dest[OF assms(1)] qbs_closed1_dest[OF assms(2)]
    by(auto intro!: qbs_probI prob_space.prob_space_distr prob_space_pair
              simp: pair_qbs_Mx_def comp_def prob_space_return)
  show "qbs_return (X ⨂Q Y) (α r, β k) = qbs_prob_space (X ⨂Q Y,map_prod α β ∘ real_real.g, distr (return real_borel r ⨂M return real_borel k) real_borel real_real.f)"
       "qbs_prob (X ⨂Q Y) (map_prod α β ∘ real_real.g) (distr (return real_borel r ⨂M return real_borel k) real_borel real_real.f)"
  proof -
    show "qbs_return (X ⨂Q Y) (α r, β k) = qbs_prob_space (X ⨂Q Y, map_prod α β ∘ real_real.g, distr (return real_borel r ⨂M return real_borel k) real_borel real_real.f)"
         (is "?lhs = ?rhs")
    proof -
      have 1:"(λr. qbs_prob_space (Y, β, return real_borel k)) ∈ monadP_qbs_MPx Y"
        by(auto intro!: in_MPx.intro bexI[where x=β] bexI[where x="λr. return real_borel k"] simp: monadP_qbs_MPx_def assms(2))
      have "?lhs = (qbs_strength X Y ∘ map_prod id (qbs_return Y)) (α r, β k)"
        by(intro qbs_strength_law3[of "(α r, β k)" X Y]) (use assms in auto)
      also have "... = qbs_strength X Y (α r, qbs_prob_space (Y, β, return real_borel k))"
        using fun_cong[OF qbs_return_comp[OF assms(2)]] by simp
      also have "... = ?rhs"
        by(intro qbs_strength_ab_r(2)[OF assms(1) 1 assms(2) _ refl,of r]) auto
      finally show ?thesis .
    qed
  qed(rule qp.qbs_prob_axioms)
qed


lemma pair_return_return:
  assumes "l ∈ space M"
      and "r ∈ space N"
    shows "return M l ⨂M return N r = return (M ⨂M N) (l,r)"
proof(auto intro!: measure_eqI)
  fix A
  assume h:"A ∈ sets (M ⨂M N)"
  show "emeasure (return M l ⨂M return N r) A = indicator A (l, r)"
       (is "?lhs = ?rhs")
  proof -
    have "?lhs = (∫+ x. ∫+ y. indicator A (x, y) ∂return N r ∂return M l)"
      by(auto intro!: sigma_finite_measure.emeasure_pair_measure prob_space_imp_sigma_finite simp: h prob_space_return assms)
    also have "... = (∫+ x. indicator A (x, r) ∂return M l)"
      using h by(auto intro!: nn_integral_cong nn_integral_return simp: assms(2))
    also have "... = ?rhs"
      using h by(auto intro!: nn_integral_return simp: assms)
    finally show ?thesis .
  qed
qed

lemma bind_bind_return_distr:
  assumes "real_distribution μ"
      and "real_distribution ν"
    shows "μ ⤜ (λr. ν ⤜ (λl. distr (return real_borel r ⨂M return real_borel l) real_borel real_real.f))
           = distr (μ ⨂M ν) real_borel real_real.f"
    (is "?lhs = ?rhs")
proof -
  interpret rd1: real_distribution μ by fact
  interpret rd2: real_distribution ν by fact
  interpret pp: pair_prob_space μ ν
    by (simp add: pair_prob_space.intro pair_sigma_finite_def rd1.prob_space_axioms rd1.sigma_finite_measure_axioms rd2.prob_space_axioms rd2.sigma_finite_measure_axioms)
  have "?lhs = μ ⤜ (λr. ν ⤜ (λl. distr (return (real_borel ⨂M real_borel) (r,l)) real_borel real_real.f))"
    using pair_return_return[of _ real_borel _ real_borel] by simp
  also have "... = μ ⤜ (λr. ν ⤜ (λl. distr (return (μ ⨂M ν) (r, l)) real_borel real_real.f))"
  proof -
    have "return (real_borel ⨂M real_borel) = return (μ ⨂M ν)"
      by(auto intro!: return_sets_cong sets_pair_measure_cong)
    thus ?thesis by simp
  qed
  also have "... = μ ⤜ (λr. distr (ν ⤜ (λl. (return (μ ⨂M ν) (r, l)))) real_borel real_real.f)"
    by(auto intro!: bind_cong distr_bind[symmetric,where K="μ ⨂M ν"])
  also have "... = distr (μ ⤜ (λr. ν ⤜ (λl. return (μ ⨂M ν) (r, l)))) real_borel real_real.f"
    by(auto intro!: distr_bind[symmetric,where K="μ ⨂M ν"])
  also have "... = ?rhs"
    by(simp add: pp.pair_measure_eq_bind[symmetric])
  finally show ?thesis .
qed

lemma(in pair_qbs_probs) qbs_bind_return_qp:
  shows "qbs_prob_space (Y, β, ν) ⤜ (λy. qbs_prob_space (X, α, μ) ⤜ (λx. qbs_return (X ⨂Q Y) (x,y))) = qbs_prob_space (X ⨂Q Y, map_prod α β ∘ real_real.g, distr (μ ⨂M ν) real_borel real_real.f)"
        "qbs_prob (X ⨂Q Y) (map_prod α β ∘ real_real.g) (distr (μ ⨂M ν) real_borel real_real.f)"
proof -
  show "qbs_prob_space (Y, β, ν) ⤜ (λy. qbs_prob_space (X, α, μ) ⤜ (λx. qbs_return (X ⨂Q Y) (x, y))) = qbs_prob_space (X ⨂Q Y, map_prod α β ∘ real_real.g, distr (μ ⨂M ν) real_borel real_real.f)"
       (is "?lhs = ?rhs")
  proof -
    have "?lhs = qbs_prob_space (X ⨂Q Y, map_prod α β ∘ real_real.g, ν ⤜ (λl. μ ⤜ (λr. distr (return real_borel r ⨂M return real_borel l) real_borel real_real.f)))"
    proof(auto intro!: qp2.qbs_bind_computation(2) measurable_bind_prob_space2[where N=real_borel] simp: in_Mx[simplified])
      show "(λy. qbs_prob_space (X, α, μ) ⤜ (λx. qbs_return (X ⨂Q Y) (x, y))) ∈ Y →Q monadP_qbs (X ⨂Q Y)"
        using qbs_morphism_const[of _ "monadP_qbs X" Y,simplified,OF qp1.qbs_prob_space_in_Px] curry_preserves_morphisms[OF qbs_morphism_pair_swap[OF qbs_return_morphism[of "X ⨂Q Y"]]]
        by (auto intro!: qbs_bind_morphism)
    next
      show "(λy. qbs_prob_space (X, α, μ) ⤜ (λx. qbs_return (X ⨂Q Y) (x, y))) ∘ β = (λr. qbs_prob_space (X ⨂Q Y, map_prod α β ∘ real_real.g, μ ⤜ (λl. distr (return real_borel l ⨂M return real_borel r) real_borel real_real.f)))"
        by standard
           (auto intro!: qp1.qbs_bind_computation(2) qbs_morphism_comp[OF qbs_morphism_Pair2[of _ Y] qbs_return_morphism[of "X ⨂Q Y"],simplified comp_def]
                  simp: in_Mx[simplified] qbs_return_Mxpair[OF qp1.in_Mx qp2.in_Mx] qbs_Mx_to_X(2))
    qed
    also have "... = ?rhs"
    proof -
      have "ν ⤜ (λl. μ ⤜ (λr. distr (return real_borel r ⨂M return real_borel l) real_borel real_real.f)) = distr (μ ⨂M ν) real_borel real_real.f"
        by(auto intro!: bind_rotate[symmetric,where N=real_borel] measurable_prob_algebraD
                  simp: bind_bind_return_distr[symmetric,OF qp1.real_distribution_axioms qp2.real_distribution_axioms])
      thus ?thesis by simp
    qed
    finally show ?thesis .
  qed
  show "qbs_prob (X ⨂Q Y) (map_prod α β ∘ real_real.g) (distr (μ ⨂M ν) real_borel real_real.f)"
    by(rule qbs_prob_axioms)
qed

lemma(in pair_qbs_probs) qbs_bind_return_pq:
  shows "qbs_prob_space (X, α, μ) ⤜ (λx. qbs_prob_space (Y, β, ν) ⤜ (λy. qbs_return (X ⨂Q Y) (x,y))) = qbs_prob_space (X ⨂Q Y, map_prod α β ∘ real_real.g, distr (μ ⨂M ν) real_borel real_real.f)"
        "qbs_prob (X ⨂Q Y) (map_prod α β ∘ real_real.g) (distr (μ ⨂M ν) real_borel real_real.f)"
proof(simp_all add: qbs_bind_return_qp(2))
  show "qbs_prob_space (X, α, μ) ⤜ (λx. qbs_prob_space (Y, β, ν) ⤜ (λy. qbs_return (X ⨂Q Y) (x, y))) = qbs_prob_space (X ⨂Q Y, map_prod α β ∘ real_real.g, distr (μ ⨂M ν) real_borel real_real.f)"
       (is "?lhs = _")
  proof -
    have "?lhs = qbs_prob_space (X ⨂Q Y, map_prod α β ∘ real_real.g, μ ⤜ (λr. ν ⤜ (λl. distr (return real_borel r ⨂M return real_borel l) real_borel real_real.f)))"
    proof(auto intro!: qp1.qbs_bind_computation(2) measurable_bind_prob_space2[where N=real_borel])
      show "(λx. qbs_prob_space (Y, β, ν) ⤜ (λy. qbs_return (X ⨂Q Y) (x, y))) ∈ X →Q monadP_qbs (X ⨂Q Y)"
        using qbs_morphism_const[of _ "monadP_qbs Y" X,simplified,OF qp2.qbs_prob_space_in_Px] curry_preserves_morphisms[OF qbs_return_morphism[of "X ⨂Q Y"]]
        by(auto intro!: qbs_bind_morphism simp: curry_def)
    next
      show "(λx. qbs_prob_space (Y, β, ν) ⤜ (λy. qbs_return (X ⨂Q Y) (x, y))) ∘ α = (λr. qbs_prob_space (X ⨂Q Y, map_prod α β ∘ real_real.g, ν ⤜ (λl. distr (return real_borel r ⨂M return real_borel l) real_borel real_real.f)))"
        by standard
          (auto intro!: qp2.qbs_bind_computation(2) qbs_morphism_comp[OF qbs_morphism_Pair1[of _ X] qbs_return_morphism[of "X ⨂Q Y"],simplified comp_def]
                  simp:  qbs_return_Mxpair[OF qp1.in_Mx qp2.in_Mx] qbs_Mx_to_X(2))
    qed
    thus ?thesis
      by(simp add: bind_bind_return_distr[OF qp1.real_distribution_axioms qp2.real_distribution_axioms])
  qed
qed

lemma qbs_bind_return_rotate:
  assumes "p ∈ monadP_qbs_Px X"
      and "q ∈ monadP_qbs_Px Y"
    shows "q ⤜ (λy. p ⤜ (λx. qbs_return (X ⨂Q Y) (x,y))) = p ⤜ (λx. q ⤜ (λy. qbs_return (X ⨂Q Y) (x,y)))"
proof -
  obtain α μ where hp:
    "qbs_prob X α μ" "p = qbs_prob_space (X, α, μ)"
    using rep_monadP_qbs_Px[OF assms(1)] by auto
  obtain β ν where hq:
    "qbs_prob Y β ν" "q = qbs_prob_space (Y, β, ν)"
    using rep_monadP_qbs_Px[OF assms(2)] by auto
  interpret pqp: pair_qbs_probs X α μ Y β ν
    by(simp add: pair_qbs_probs_def hp hq)
  show ?thesis
    by(simp add: hp(2) hq(2) pqp.qbs_bind_return_pq(1) pqp.qbs_bind_return_qp)
qed

lemma qbs_pair_bind_return1:
  assumes "f ∈  X ⨂Q Y →Q monadP_qbs Z"
          "p ∈ monadP_qbs_Px X"
      and "q ∈ monadP_qbs_Px Y"
    shows "q ⤜ (λy. p ⤜ (λx. f (x,y))) = (q ⤜ (λy. p ⤜ (λx. qbs_return (X ⨂Q Y) (x,y)))) ⤜ f"
          (is "?lhs = ?rhs")
proof -
  note [simp] = qbs_morphism_const[of _ "monadP_qbs X",simplified,OF assms(2)]
                qbs_morphism_Pair1'[OF _ assms(1)] qbs_morphism_Pair2'[OF _ assms(1)]
                curry_preserves_morphisms[OF qbs_morphism_pair_swap[OF qbs_return_morphism[of "X ⨂Q Y"]],simplified curry_def,simplified]
                qbs_morphism_Pair2'[OF _ qbs_return_morphism[of "X ⨂Q Y"]]
                arg_swap_morphism[OF curry_preserves_morphisms[OF assms(1)],simplified curry_def]
                curry_preserves_morphisms[OF qbs_morphism_comp[OF qbs_morphism_pair_swap[OF qbs_return_morphism[of "X ⨂Q Y"]] qbs_bind_morphism'[OF assms(1)]],simplified curry_def comp_def,simplified]
  have [simp]:"(λy. p ⤜ (λx. f (x,y))) ∈ Y →Q monadP_qbs Z"
              "(λy. p ⤜ (λx. qbs_return (X ⨂Q Y) (x,y) ⤜ f)) ∈ Y →Q monadP_qbs Z"
    by(auto intro!: qbs_bind_morphism[where Y=X] simp: curry_def)
  have "?lhs = q ⤜ (λy. p ⤜ (λx. qbs_return (X ⨂Q Y) (x,y) ⤜ f))"
    by(auto intro!: qbs_bind_cong[OF assms(3),where Y=Z] qbs_bind_cong[OF assms(2),where Y=Z] simp: qbs_bind_return[OF assms(1)])
  also have "... = q ⤜ (λy. (p ⤜ (λx. qbs_return (X ⨂Q Y) (x,y))) ⤜ f)"
    by(auto intro!: qbs_bind_cong[OF assms(3),where Y=Z] qbs_bind_assoc[OF assms(2) _ assms(1)] simp: )
  also have "... = ?rhs"
    by(auto intro!: qbs_bind_assoc[OF assms(3)_ assms(1)] qbs_bind_morphism[where Y=X])
  finally show ?thesis .
qed

lemma qbs_pair_bind_return2:
  assumes "f ∈  X ⨂Q Y →Q monadP_qbs Z"
          "p ∈ monadP_qbs_Px X"
      and "q ∈ monadP_qbs_Px Y"
    shows "p ⤜ (λx. q ⤜ (λy. f (x,y))) = (p ⤜ (λx. q ⤜ (λy. qbs_return (X ⨂Q Y) (x,y)))) ⤜ f"
          (is "?lhs = ?rhs")      
proof -
  note [simp] = qbs_morphism_const[of _ "monadP_qbs Y",simplified,OF assms(3)]
                qbs_morphism_Pair1'[OF _ assms(1)] curry_preserves_morphisms[OF assms(1),simplified curry_def]
                qbs_morphism_Pair1'[OF _ qbs_return_morphism[of "X ⨂Q Y"]]
                curry_preserves_morphisms[OF qbs_morphism_comp[OF qbs_return_morphism[of "X ⨂Q Y"] qbs_bind_morphism'[OF assms(1)]],simplified curry_def comp_def,simplified]
                curry_preserves_morphisms[OF qbs_return_morphism[of "X ⨂Q Y"],simplified curry_def]
  have [simp]: "(λx. q ⤜ (λy. f (x, y))) ∈ X →Q monadP_qbs Z"
               "(λx. q ⤜ (λy. qbs_return (X ⨂Q Y) (x, y) ⤜ f)) ∈ X →Q monadP_qbs Z"
     by(auto intro!: qbs_bind_morphism[where Y=Y])
  have "?lhs = p ⤜ (λx. q ⤜ (λy. qbs_return (X ⨂Q Y) (x,y) ⤜ f))"
    by(auto intro!: qbs_bind_cong[OF assms(2),where Y=Z] qbs_bind_cong[OF assms(3),where Y=Z] simp: qbs_bind_return[OF assms(1)])
  also have "... = p ⤜ (λx. (q ⤜ (λy. qbs_return (X ⨂Q Y) (x,y))) ⤜ f)"
    by(auto intro!: qbs_bind_cong[OF assms(2),where Y=Z] qbs_bind_assoc[OF assms(3) _ assms(1)])
  also have "... = ?rhs"
    by(auto intro!: qbs_bind_assoc[OF assms(2) _ assms(1)] qbs_bind_morphism[where Y=Y])
  finally show ?thesis .
qed

lemma qbs_bind_rotate:
  assumes "f ∈  X ⨂Q Y →Q monadP_qbs Z"
          "p ∈ monadP_qbs_Px X"
      and "q ∈ monadP_qbs_Px Y"
    shows "q ⤜ (λy. p ⤜ (λx. f (x,y))) = p ⤜ (λx. q ⤜ (λy. f (x,y)))"
  using qbs_pair_bind_return1[OF assms(1) assms(2) assms(3)] qbs_bind_return_rotate[OF assms(2) assms(3)] qbs_pair_bind_return2[OF assms(1) assms(2) assms(3)]
  by simp


lemma(in pair_qbs_probs) qbs_bind_bind_return:
  assumes "f ∈  X ⨂Q Y →Q Z"
  shows "qbs_prob Z (f ∘ (map_prod α β ∘ real_real.g)) (distr (μ ⨂M ν) real_borel real_real.f)"
    and "qbs_prob_space (X,α,μ) ⤜ (λx. qbs_prob_space (Y,β,ν) ⤜ (λy. qbs_return Z (f (x,y)))) = qbs_prob_space (Z,f ∘ (map_prod α β ∘ real_real.g),distr (μ ⨂M ν) real_borel real_real.f)"
        (is "?lhs = ?rhs")
proof -
  show "qbs_prob Z (f ∘ (map_prod α β ∘ real_real.g)) (distr (μ ⨂M ν) real_borel real_real.f)"
    using qbs_bind_return_qp(2) qbs_morphismE(3)[OF assms] by(simp add: qbs_prob_def in_Mx_def)
next
  have "?lhs = (qbs_prob_space (X,α,μ) ⤜ (λx. qbs_prob_space (Y,β,ν) ⤜ (λy. qbs_return (X ⨂Q Y) (x,y)))) ⤜ qbs_return Z ∘ f"
    using qbs_pair_bind_return2[OF qbs_morphism_comp[OF assms qbs_return_morphism] qp1.qbs_prob_space_in_Px qp2.qbs_prob_space_in_Px]
    by(simp add: comp_def)
  also have "... = qbs_prob_space (X ⨂Q Y, map_prod α β ∘ real_real.g, distr (μ ⨂M ν) real_borel real_real.f) ⤜ qbs_return Z ∘ f"
    by(simp add: qbs_bind_return_pq(1))
  also have "... = ?rhs"
    by(rule monadP_qbs_Pf_computation[OF refl assms,simplified monadP_qbs_Pf_def])
  finally show "?lhs = ?rhs" .
qed

subsubsection ‹ Properties of Return and Bind ›
lemma qbs_prob_measure_return:
  assumes "x ∈ qbs_space X"
  shows "qbs_prob_measure (qbs_return X x) = return (qbs_to_measure X) x"
proof -
  interpret qp: qbs_prob X "λr. x" "return real_borel 0"
    by(auto intro!: qbs_probI simp: prob_space_return assms)
  show ?thesis
    by(simp add: qp.qbs_return_computation[OF assms] distr_return)
qed

lemma qbs_prob_measure_bind:
  assumes "s ∈ monadP_qbs_Px X"
      and "f ∈ X →Q monadP_qbs Y"
    shows "qbs_prob_measure (s ⤜ f) = qbs_prob_measure s ⤜ qbs_prob_measure ∘ f"
          (is "?lhs = ?rhs")
proof -
  obtain α μ where hs:
  "qbs_prob X α μ" "s = qbs_prob_space (X, α, μ)"
    using rep_monadP_qbs_Px[OF assms(1)] by blast
  hence "f ∘ α ∈ monadP_qbs_MPx Y"
    using assms(2) by(auto simp: qbs_prob_def in_Mx_def)
  then obtain β g where hbg:
      "β ∈ qbs_Mx Y" "g ∈ real_borel →M prob_algebra real_borel"
      "(f ∘ α) = (λr. qbs_prob_space (Y, β, g r))"
    using rep_monadP_qbs_MPx by blast
  note [measurable] = hbg(2)
  have [measurable]:"f ∈ qbs_to_measure X →M qbs_to_measure (monadP_qbs Y)"
    using l_preserves_morphisms assms(2) by auto 
  interpret pqp: pair_qbs_probs X α μ Y β "μ ⤜ g"
    by(simp add: pair_qbs_probs_def hs(1) qbs_prob.qbs_bind_computation[OF hs assms(2) hbg])

  have "?lhs = distr (μ ⤜ g) (qbs_to_measure Y) β"
    by(simp add: pqp.qp1.qbs_bind_computation[OF hs(2) assms(2) hbg])
  also have "... = μ ⤜ (λx. distr (g x) (qbs_to_measure Y) β)"
    by(auto intro!: distr_bind[where K=real_borel] measurable_prob_algebraD)
  also have "... = μ ⤜ (λx. qbs_prob_measure (qbs_prob_space (Y,β,g x)))"
    using measurable_space[OF hbg(2)]
    by(auto intro!: bind_cong qbs_prob.qbs_prob_measure_computation[symmetric] qbs_probI simp: space_prob_algebra)
  also have "... = μ ⤜ (λx. qbs_prob_measure ((f ∘ α) x))"
    by(simp add: hbg(3))
  also have "... = μ ⤜ (λx. (qbs_prob_measure ∘ f) (α x))" by simp
  also have "... = distr μ (qbs_to_measure X) α ⤜ qbs_prob_measure ∘ f"
    by(intro bind_distr[symmetric,where K="qbs_to_measure Y"]) auto
  also have "... = ?rhs"
    by(simp add: hs(2))
  finally show ?thesis .
qed

lemma qbs_of_return:
  assumes "x ∈ qbs_space X"
  shows "qbs_prob_space_qbs (qbs_return X x) = X"
  using real_distribution.qbs_return_computation[OF _ assms,of "return real_borel 0"]
        qbs_prob.qbs_prob_space_qbs_computation[of X "λr. x" "return real_borel 0"] assms
  by(auto simp: qbs_prob_def in_Mx_def real_distribution_def real_distribution_axioms_def prob_space_return)

lemma qbs_of_bind:
  assumes "s ∈ monadP_qbs_Px X"
      and "f ∈ X →Q monadP_qbs Y"
    shows "qbs_prob_space_qbs (s ⤜ f) = Y"
proof -
  obtain α μ where hs:
   "qbs_prob X α μ" "s = qbs_prob_space (X, α, μ)"
    using rep_monadP_qbs_Px[OF assms(1)] by auto
  hence "f ∘ α ∈ monadP_qbs_MPx Y"
    using assms(2) by(auto simp: qbs_prob_def in_Mx_def)
  then obtain β g where hbg:
      "β ∈ qbs_Mx Y" "g ∈ real_borel →M prob_algebra real_borel"
      "(f ∘ α) = (λr. qbs_prob_space (Y, β, g r))"
    using rep_monadP_qbs_MPx by blast
  show ?thesis
    using qbs_prob.qbs_bind_computation[OF hs assms(2) hbg] qbs_prob.qbs_prob_space_qbs_computation
    by simp
qed

subsubsection ‹ Properties of Integrals›
lemma qbs_integrable_return:
  assumes "x ∈ qbs_space X" 
      and "f ∈ X →Q ℝQ"
    shows "qbs_integrable (qbs_return X x) f"
  using assms(2) nn_integral_return[of x "qbs_to_measure X" "λx. ¦f x¦",simplified,OF assms(1)]
  by(auto intro!: qbs_integrable_if_integrable integrableI_bounded
            simp: qbs_prob_measure_return[OF assms(1)] )

lemma qbs_integrable_bind_return:
  assumes "s ∈ monadP_qbs_Px Y"
          "f ∈ Z →Q ℝQ"
      and "g ∈ Y →Q Z"
    shows "qbs_integrable (s ⤜ (λy. qbs_return Z (g y))) f = qbs_integrable s (f ∘ g)"
proof -
  obtain α μ where hs:
   "qbs_prob Y α μ" "s = qbs_prob_space (Y, α, μ)"
    using rep_monadP_qbs_Px[OF assms(1)] by auto
  then interpret qp: qbs_prob Y α μ by simp
  show ?thesis (is "?lhs = ?rhs")
  proof -
    have "qbs_return Z ∘ (g ∘ α) = (λr. qbs_prob_space (Z, g ∘ α, return real_borel r))"
      by(rule qbs_return_comp) (use assms(3) qp.in_Mx in blast)
    hence hb:"qbs_prob Z (g ∘ α) μ"
             "s ⤜ (λy. qbs_return Z (g y)) = qbs_prob_space (Z, g ∘ α, μ)"
       by(auto intro!: qbs_prob.qbs_bind_computation[OF hs qbs_morphism_comp[OF assms(3) qbs_return_morphism,simplified comp_def] qbs_morphismE(3)[OF assms(3) qp.in_Mx],of "return real_borel",simplified bind_return''[of μ real_borel,simplified]])
         (simp_all add: comp_def)
    have "?lhs = integrable μ (f ∘ (g ∘ α))"
      using assms(2)
      by(auto intro!: qbs_prob.qbs_integrable_iff_integrable[OF hb(1),simplified comp_def] simp: hb(2) comp_def)
    also have "... = ?rhs"
      using qbs_morphism_comp[OF assms(3,2)]
      by(auto intro!: qbs_prob.qbs_integrable_iff_integrable[OF hs(1),symmetric] simp: hs(2) comp_def)
    finally show ?thesis .
  qed
qed


lemma qbs_prob_ennintegral_morphism:
  assumes "L ∈ X →Q monadP_qbs Y"
      and "f ∈ X →Q exp_qbs Y ℝQ≥0"
    shows "(λx. qbs_prob_ennintegral (L x) (f x)) ∈ X →Q ℝQ≥0"
proof(rule qbs_morphismI,simp_all)
  fix α
  assume h0:"α ∈ qbs_Mx X"
  then obtain β g where h:
   "β ∈ qbs_Mx Y" "g ∈ real_borel →M prob_algebra real_borel"
   "(L ∘ α) = (λr. qbs_prob_space (Y, β, g r))"
    using rep_monadP_qbs_MPx[of "L ∘ α" Y] qbs_morphismE(3)[OF assms(1)] by auto
  note [measurable] = h(2)
  have [measurable]: "(λ(r, y). f (α r) (β y)) ∈ real_borel ⨂M real_borel →M ennreal_borel"
  proof -
    have "(λ(r, y). f (α r) (β y)) = case_prod f ∘ map_prod α β"
      by auto
    also have "... ∈ ℝQ ⨂Q ℝQ →Q ℝQ≥0"
      apply(rule qbs_morphism_comp[OF qbs_morphism_map_prod uncurry_preserves_morphisms[OF assms(2)]])
      using h0 h(1) by(auto simp: qbs_Mx_is_morphisms)
    finally show ?thesis
      by auto
  qed
  have "(λx. qbs_prob_ennintegral (L x) (f x)) ∘ α = (λr. qbs_prob_ennintegral ((L ∘ α) r) ((f ∘ α) r))"
    by auto
  also have "... = (λr. (∫+ x. (f ∘ α) r (β x) ∂(g r)))"
    apply standard
    using h0 by(auto intro!: qbs_prob.qbs_prob_ennintegral_def[OF qbs_prob_MPx[OF h(1,2)]] qbs_morphismE(2)[OF assms(2),simplified] simp: h(3))
  also have "... ∈ real_borel →M ennreal_borel"
    using assms(2) h0 h(1)
    by(auto intro!: nn_integral_measurable_subprob_algebra2[where N=real_borel] simp: measurable_prob_algebraD)
  finally show "(λx. qbs_prob_ennintegral (L x) (f x)) ∘ α ∈ real_borel →M ennreal_borel " .
qed

lemma qbs_morphism_ennintegral_fst:
  assumes "q ∈ monadP_qbs_Px Y"
      and "f ∈ X ⨂Q Y →Q ℝQ≥0"
    shows "(λx. ∫+Q y. f (x, y) ∂q) ∈ X →Q ℝQ≥0"
  by(rule qbs_prob_ennintegral_morphism[OF qbs_morphism_const[of _  "monadP_qbs Y",simplified,OF assms(1)] curry_preserves_morphisms[OF assms(2)],simplified curry_def])

lemma qbs_morphism_ennintegral_snd:
  assumes "p ∈ monadP_qbs_Px X"
      and "f ∈ X ⨂Q Y →Q ℝQ≥0"
    shows "(λy. ∫+Q x. f (x, y) ∂p) ∈ Y →Q ℝQ≥0"
  using qbs_morphism_ennintegral_fst[OF assms(1) qbs_morphism_pair_swap[OF assms(2)]]
  by fastforce

lemma qbs_prob_ennintegral_morphism':
  assumes "f ∈ X →Q ℝQ≥0"
  shows "(λs. qbs_prob_ennintegral s f) ∈ monadP_qbs X →Q ℝQ≥0"
  apply(rule qbs_prob_ennintegral_morphism[of _ _ X])
  using qbs_morphism_ident[of "monadP_qbs X"]
   apply (simp add: id_def)
  using assms qbs_morphism_const[of f "exp_qbs X ℝQ≥0"]
  by simp

lemma qbs_prob_ennintegral_return:
  assumes "f ∈ X →Q ℝQ≥0"
      and "x ∈ qbs_space X"
    shows "qbs_prob_ennintegral (qbs_return X x) f = f x"
  using assms
  by(auto intro!: nn_integral_return
            simp: qbs_prob_ennintegral_def2[OF qbs_of_return[OF assms(2)] assms(1)] qbs_prob_measure_return[OF assms(2)])

lemma qbs_prob_ennintegral_bind:
  assumes "s ∈ monadP_qbs_Px X"
          "f ∈ X →Q monadP_qbs Y"
      and "g ∈ Y →Q ℝQ≥0"
    shows "qbs_prob_ennintegral (s ⤜ f) g = qbs_prob_ennintegral s (λy. (qbs_prob_ennintegral (f y) g))"
          (is "?lhs = ?rhs")
proof -
  obtain α μ where hs:
   "qbs_prob X α μ" "s = qbs_prob_space (X, α, μ)"
    using rep_monadP_qbs_Px[OF assms(1)] by auto
  then interpret qp: qbs_prob X α μ by simp
  obtain β h where hb:
   "β ∈ qbs_Mx Y" "h ∈ real_borel →M prob_algebra real_borel"
   "(f ∘ α) = (λr. qbs_prob_space (Y, β, h r))"
    using rep_monadP_qbs_MPx[OF qbs_morphismE(3)[OF assms(2) qp.in_Mx,simplified]]
    by auto
  hence h:"qbs_prob Y β (μ ⤜ h)"
          "s ⤜ f = qbs_prob_space (Y, β, μ ⤜ h)"
    using qp.qbs_bind_computation[OF hs(2) assms(2) hb] by auto
  hence LHS:"?lhs = (∫+ x. g (β x) ∂(μ ⤜ h))"
    using qbs_prob.qbs_prob_ennintegral_def[OF h(1) assms(3)]
    by simp
  note [measurable] = hb(2)

  have "⋀r. qbs_prob_ennintegral (f (α r)) g = (∫+ y. g (β y) ∂(h r))"
    using qbs_prob.qbs_prob_ennintegral_def[OF qbs_prob_MPx[OF hb(1,2)] assms(3)] hb(3)[simplified comp_def]
    by metis
  hence "?rhs = (∫+ r. (∫+ y. (g ∘ β) y ∂(h r)) ∂μ)"
    by(auto intro!: nn_integral_cong
              simp: qbs_prob.qbs_prob_ennintegral_def[OF hs(1)  qbs_prob_ennintegral_morphism[OF assms(2) qbs_morphism_const[of _ "exp_qbs Y ℝQ≥0 ",simplified,OF assms(3)]]] hs(2))
  also have "... = (integralN (μ ⤜ h) (g ∘ β))"
    apply(intro nn_integral_bind[symmetric,of _ real_borel])
    using assms(3) hb(1)
    by(auto intro!: measurable_prob_algebraD hb(2))
  finally show ?thesis
    using LHS by(simp add: comp_def)
qed

lemma qbs_prob_ennintegral_bind_return:
  assumes "s ∈ monadP_qbs_Px Y"
          "f ∈ Z →Q ℝQ≥0"
      and "g ∈ Y →Q Z"
    shows "qbs_prob_ennintegral (s ⤜ (λy. qbs_return Z (g y))) f = qbs_prob_ennintegral s (f ∘ g)"
  apply(simp add: qbs_prob_ennintegral_bind[OF assms(1) qbs_return_morphism'[OF assms(3)] assms(2)])
  using assms(1,3)
  by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_return[OF assms(2)]
            simp: monadP_qbs_Px_def)

lemma qbs_prob_integral_morphism':
  assumes "f ∈ X →Q ℝQ"
  shows "(λs. qbs_prob_integral s f) ∈ monadP_qbs X →Q ℝQ"
proof(rule qbs_morphismI;simp)
  fix α
  assume "α ∈ monadP_qbs_MPx X"
  then obtain β g where h:
   "β ∈ qbs_Mx X" "g ∈ real_borel →M prob_algebra real_borel"
   "α = (λr. qbs_prob_space (X, β, g r))"
    using rep_monadP_qbs_MPx[of α X] by auto
  note [measurable] = h(2)
  have [measurable]: "f ∘ β ∈ real_borel →M real_borel"
    using assms h(1) by auto
  have "(λs. qbs_prob_integral s f) ∘ α = (λr. ∫ x. f (β x) ∂g r)"
    apply standard
    using assms qbs_prob_MPx[OF h(1,2)] by(auto intro!: qbs_prob.qbs_prob_integral_def simp: h(3))
  also have "... = (λM. integralL M (f ∘ β)) ∘ g"
    by (simp add: comp_def)
  also have "... ∈ real_borel →M real_borel"
    by(auto intro!: measurable_comp[where N="subprob_algebra real_borel"] 
              simp: integral_measurable_subprob_algebra measurable_prob_algebraD)
  finally show "(λs. qbs_prob_integral s f) ∘ α ∈ real_borel →M real_borel" .
qed

lemma qbs_morphism_integral_fst:
  assumes "q ∈ monadP_qbs_Px Y"
      and "f ∈ X ⨂Q Y →Q ℝQ"
    shows "(λx. ∫Q y. f (x, y) ∂q) ∈ X →Q ℝQ"
proof(rule qbs_morphismI,simp_all)
  fix α
  assume ha:"α ∈ qbs_Mx X"
  obtain β ν where hq:
  "qbs_prob Y β ν" "q = qbs_prob_space (Y, β, ν)"
    using rep_monadP_qbs_Px[OF assms(1)] by auto
  then interpret qp: qbs_prob Y β ν by simp
  have "(λx. ∫Q y. f (x, y) ∂q) ∘ α = (λx. ∫ y. f (α x, β y) ∂ν)"
    apply standard
    using qbs_morphism_Pair1'[OF qbs_Mx_to_X(2)[OF ha] assms(2)]
    by(auto intro!: qp.qbs_prob_integral_def
              simp: hq(2))
  also have "... ∈ borel_measurable borel"
    using qbs_morphism_comp[OF qbs_morphism_map_prod assms(2),of α "ℝQ" β "ℝQ",simplified comp_def map_prod_def split_beta'] ha qp.in_Mx
    by(auto intro!: qp.borel_measurable_lebesgue_integral
              simp: qbs_Mx_is_morphisms)
  finally show "(λx. ∫Q y. f (x, y) ∂q) ∘ α ∈ borel_measurable borel" .
qed

lemma qbs_morphism_integral_snd:
  assumes "p ∈ monadP_qbs_Px X"
      and "f ∈ X ⨂Q Y →Q ℝQ"
    shows "(λy. ∫Q x. f (x, y) ∂p) ∈ Y →Q ℝQ"
  using qbs_morphism_integral_fst[OF assms(1) qbs_morphism_pair_swap[OF assms(2)]]
  by simp

lemma qbs_prob_integral_morphism:
  assumes "L ∈ X →Q monadP_qbs Y"
          "f ∈ X →Q exp_qbs Y ℝQ"
      and "⋀x. x ∈ qbs_space X ⟹ qbs_integrable (L x) (f x)"
    shows "(λx. qbs_prob_integral (L x) (f x)) ∈ X →Q ℝQ"
proof(rule qbs_morphismI;simp)
  fix α
  assume h0:"α ∈ qbs_Mx X"
  then obtain β g where h:
   "β ∈ qbs_Mx Y" "g ∈ real_borel →M prob_algebra real_borel"
   "(L ∘ α) = (λr. qbs_prob_space (Y, β, g r))"
    using rep_monadP_qbs_MPx[of "L ∘ α" Y] qbs_morphismE(3)[OF assms(1)] by auto
  have "(λx. qbs_prob_integral (L x) (f x)) ∘ α = (λr. qbs_prob_integral ((L ∘ α) r) ((f ∘ α) r))"
    by auto
  also have "... = (λr. enn2real (qbs_prob_ennintegral ((L ∘ α) r) (λx. ennreal ((f ∘ α) r x)))
                      - enn2real (qbs_prob_ennintegral ((L ∘ α) r) (λx. ennreal (- (f ∘ α) r x))))"
    using h0 assms(3) by(auto intro!: real_qbs_prob_integral_def)
  also have "... ∈ real_borel →M real_borel"
  proof -
    have h2:"L ∘ α ∈ ℝQ →Q monadP_qbs Y"
      using qbs_morphismE(3)[OF assms(1) h0] by(auto simp: qbs_Mx_is_morphisms)
    have [measurable]:"(λx. f (fst x) (snd x)) ∈ qbs_to_measure (X ⨂Q Y) →M real_borel"
      using uncurry_preserves_morphisms[OF assms(2)] by(auto simp: split_beta')
    have h3:"(λr x. ennreal ((f ∘ α) r x)) ∈ ℝQ →Q exp_qbs Y ℝQ≥0"
    proof(auto intro!: curry_preserves_morphisms[of "(λ(r,x). ennreal ((f ∘ α) r x))",simplified curry_def,simplified])
     have "(λ(r, y). ennreal (f (α r) y)) = ennreal ∘ case_prod f ∘ map_prod α id"
        by auto
      also have "... ∈ ℝQ ⨂Q Y →Q ℝQ≥0"
        apply(rule qbs_morphism_comp[where Y="X ⨂Q Y"])
        using h0 qbs_morphism_map_prod[OF _ qbs_morphism_ident,of α "ℝQ" X Y]
        by(auto simp: qbs_Mx_is_morphisms)
      finally show "(λ(r, y). ennreal (f (α r) y)) ∈ qbs_to_measure (ℝQ ⨂Q Y) →M ennreal_borel"
        by auto
    qed
    have h4:"(λr x. ennreal (- (f ∘ α) r x)) ∈ ℝQ →Q exp_qbs Y ℝQ≥0"
    proof(auto intro!: curry_preserves_morphisms[of "(λ(r,x). ennreal (- (f ∘ α) r x))",simplified curry_def,simplified])
      have "(λ(r, y). ennreal (- f (α r) y)) = ennreal ∘ (λr. - r) ∘ case_prod f ∘ map_prod α id"
        by auto
      also have "... ∈ ℝQ ⨂Q Y →Q ℝQ≥0"
        apply(rule qbs_morphism_comp[where Y="X ⨂Q Y"])
        using h0 qbs_morphism_map_prod[OF _ qbs_morphism_ident,of α "ℝQ" X Y]
        by(auto simp: qbs_Mx_is_morphisms)
      finally show "(λ(r, y). ennreal (- f (α r) y)) ∈ qbs_to_measure (ℝQ ⨂Q Y) →M ennreal_borel"
        by auto
    qed
    have "(λr. qbs_prob_ennintegral ((L ∘ α) r) (λx. ennreal ((f ∘ α) r x))) ∈ real_borel →M ennreal_borel"
         "(λr. qbs_prob_ennintegral ((L ∘ α) r) (λx. ennreal (- (f ∘ α) r x))) ∈ real_borel →M ennreal_borel"
      using qbs_prob_ennintegral_morphism[OF h2 h3] qbs_prob_ennintegral_morphism[OF h2 h4]
      by auto
    thus ?thesis by simp
  qed
  finally show "(λx. qbs_prob_integral (L x) (f x)) ∘ α ∈ real_borel →M real_borel" .
qed

lemma qbs_prob_integral_morphism'':
  assumes "f ∈ X →Q ℝQ"
      and "L ∈ Y →Q monadP_qbs X"
    shows "(λy. qbs_prob_integral (L y) f) ∈ Y →Q ℝQ"
  using qbs_morphism_comp[OF assms(2) qbs_prob_integral_morphism'[OF assms(1)]]
  by(simp add: comp_def)

lemma qbs_prob_integral_return:
  assumes "f ∈ X →Q ℝQ"
      and "x ∈ qbs_space X"
    shows "qbs_prob_integral (qbs_return X x) f = f x"
  using assms
  by(auto intro!: integral_return
        simp add: qbs_prob_integral_def2 qbs_prob_measure_return[OF assms(2)])

lemma qbs_prob_integral_bind:
  assumes "s ∈ monadP_qbs_Px X"
          "f ∈ X →Q monadP_qbs Y"
          "g ∈ Y →Q ℝQ"
      and "∃K. ∀y ∈ qbs_space Y.¦g y¦ ≤ K"
    shows "qbs_prob_integral (s ⤜ f) g = qbs_prob_integral s (λy. (qbs_prob_integral (f y) g))"
          (is "?lhs = ?rhs")
proof -
  obtain K where hK:
   "⋀y. y ∈ qbs_space Y ⟹ ¦g y¦ ≤ K"
    using assms(4) by auto
  obtain α μ where hs:
   "qbs_prob X α μ" "s = qbs_prob_space (X, α, μ)"
    using rep_monadP_qbs_Px[OF assms(1)] by auto
  then obtain β h where hb:
   "β ∈ qbs_Mx Y" "h ∈ real_borel →M prob_algebra real_borel"
   "(f ∘ α) = (λr. qbs_prob_space (Y, β, h r))"
    using rep_monadP_qbs_MPx[of "f ∘ α" Y] qbs_morphismE(3)[OF assms(2)]
    by(auto simp add: qbs_prob_def in_Mx_def)
  note [measurable] = hb(2)
  interpret rd: real_distribution μ by(simp add: hs(1)[simplified qbs_prob_def])
  have h:"qbs_prob Y β (μ ⤜ h)"
         "s ⤜ f = qbs_prob_space (Y, β, μ ⤜ h)"
    using qbs_prob.qbs_bind_computation[OF hs assms(2) hb] by auto

  hence "?lhs = (∫ x. g (β x) ∂(μ ⤜ h))"
    by(simp add: qbs_prob.qbs_prob_integral_def[OF h(1) assms(3)])
  also have "... = (integralL (μ ⤜ h) (g ∘ β))" by(simp add: comp_def)
  also have "... = (∫ r. (∫ y. (g ∘ β) y ∂(h r)) ∂μ)"
    apply(rule integral_bind[of _ real_borel K _ _ 1])
    using assms(3) hb(1) hK measurable_space[OF hb(2)]
    by(auto intro!: measurable_prob_algebraD
         simp: space_prob_algebra prob_space.emeasure_le_1)
  also have "... = ?rhs"
    by(auto intro!: Bochner_Integration.integral_cong
       simp: qbs_prob.qbs_prob_integral_def[OF qbs_prob_MPx[OF hb(1,2)] assms(3)] fun_cong[OF hb(3),simplified comp_def] hs(2) qbs_prob.qbs_prob_integral_def[OF hs(1) qbs_prob_integral_morphism''[OF assms(3,2)]])
  finally show ?thesis .
qed

lemma qbs_prob_integral_bind_return:
  assumes "s ∈ monadP_qbs_Px Y"
          "f ∈ Z →Q ℝQ"
      and "g ∈ Y →Q Z"
    shows "qbs_prob_integral (s ⤜ (λy. qbs_return Z (g y))) f = qbs_prob_integral s (f ∘ g)"
proof -
  obtain α μ where hs:
   "qbs_prob Y α μ" "s = qbs_prob_space (Y, α, μ)"
    using rep_monadP_qbs_Px[OF assms(1)] by auto
  then interpret qp: qbs_prob Y α μ by simp
  have hb:"qbs_prob Z (g ∘ α) μ"
          "s ⤜ (λy. qbs_return Z (g y)) = qbs_prob_space (Z, g ∘ α, μ)"
    by(auto intro!: qp.qbs_bind_computation[OF hs(2) qbs_return_morphism'[OF assms(3)] qbs_morphismE(3)[OF assms(3) qp.in_Mx],of "return real_borel",simplified bind_return''[of μ real_borel,simplified] comp_def]
           simp: comp_def qbs_return_comp[OF qbs_morphismE(3)[OF assms(3) qp.in_Mx],simplified comp_def])
  thus ?thesis
    by(simp add: hb(2) qbs_prob.qbs_prob_integral_def[OF hb(1) assms(2)] hs(2) qbs_prob.qbs_prob_integral_def[OF hs(1) qbs_morphism_comp[OF assms(3,2)]])
qed

lemma qbs_prob_var_bind_return:
  assumes "s ∈ monadP_qbs_Px Y"
          "f ∈ Z →Q ℝQ"
      and "g ∈ Y →Q Z"
    shows "qbs_prob_var (s ⤜ (λy. qbs_return Z (g y))) f = qbs_prob_var s (f ∘ g)"
proof -
  have 1:"(λx. (f x - qbs_prob_integral s (f ∘ g))2) ∈ Z →Q ℝQ"
    using assms(2,3) by auto
  thus ?thesis
    using qbs_prob_integral_bind_return[OF assms(1) 1 assms(3)] qbs_prob_integral_bind_return[OF assms]
    by(simp add: comp_def qbs_prob_var_def)
qed

end
head>

Theory Pair_QuasiBorel_Measure

(*  Title:   Pair_QuasiBorel_Measure.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsection ‹Binary Product Measure›

theory Pair_QuasiBorel_Measure
  imports "Monad_QuasiBorel"
begin

subsubsection ‹ Binary Product Measure›
text ‹ Special case of \cite{Heunen_2017} Proposition 23 where $\Omega = \mathbb{R}\times \mathbb{R}$ and $X = X \times Y$.
      Let $[\alpha,\mu ] \in P(X)$ and $[\beta ,\nu] \in P(Y)$. $\alpha\times\beta$ is the $\alpha$ in Proposition 23. ›
definition qbs_prob_pair_measure_t :: "['a qbs_prob_t, 'b qbs_prob_t] ⇒ ('a × 'b) qbs_prob_t" where
"qbs_prob_pair_measure_t p q  ≡ (let (X,α,μ) = p;
                                     (Y,β,ν) = q in
                                 (X ⨂Q Y, map_prod α β ∘ real_real.g, distr (μ ⨂M ν) real_borel real_real.f))"

lift_definition qbs_prob_pair_measure :: "['a qbs_prob_space, 'b qbs_prob_space] ⇒ ('a × 'b) qbs_prob_space" (infix "⨂Qmes" 80)
is qbs_prob_pair_measure_t
  unfolding qbs_prob_pair_measure_t_def
proof auto
  fix X X' :: "'a quasi_borel"
  fix Y Y' :: "'b quasi_borel"
  fix α α' μ μ' β β' ν ν'
  assume h:"qbs_prob_eq (X,α,μ) (X',α',μ')"
           "qbs_prob_eq (Y,β,ν) (Y',β',ν')"
  then have 1: "X = X'" "Y = Y'"
    by(auto simp: qbs_prob_eq_def)
  interpret pqp1: pair_qbs_probs X α μ Y β ν
    by(simp add: pair_qbs_probs_def qbs_prob_eq_dest(1)[OF h(1)] qbs_prob_eq_dest(1)[OF h(2)])
  interpret pqp2: pair_qbs_probs X' α' μ' Y' β' ν'
    by(simp add: pair_qbs_probs_def qbs_prob_eq_dest(2)[OF h(1)] qbs_prob_eq_dest(2)[OF h(2)])
  interpret pqp: pair_qbs_prob "X ⨂Q Y" "map_prod α β ∘ real_real.g" "distr (μ ⨂M ν) real_borel real_real.f" "X' ⨂Q Y'" "map_prod α' β' ∘ real_real.g" "distr (μ' ⨂M ν') real_borel real_real.f"
    by(auto intro!: qbs_probI pqp1.P.prob_space_distr pqp2.P.prob_space_distr simp: pair_qbs_prob_def)

  show "qbs_prob_eq (X ⨂Q Y, map_prod α β ∘ real_real.g, distr (μ ⨂M ν) real_borel real_real.f) (X' ⨂Q Y', map_prod α' β' ∘ real_real.g, distr (μ' ⨂M ν') real_borel real_real.f)"
  proof(rule pqp.qbs_prob_space_eq_inverse(1))
    show "qbs_prob_space (X ⨂Q Y, map_prod α β ∘ real_real.g, distr (μ ⨂M ν) real_borel real_real.f)
           = qbs_prob_space (X' ⨂Q Y', map_prod α' β' ∘ real_real.g, distr (μ' ⨂M ν') real_borel real_real.f)"
         (is "?lhs = ?rhs")
    proof -
      have "?lhs = qbs_prob_space (X, α, μ) ⤜ (λx. qbs_prob_space (Y, β, ν) ⤜ (λy. qbs_return (X ⨂Q Y) (x, y)))"
        by(simp add: pqp1.qbs_bind_return_pq)
      also have "... = qbs_prob_space (X', α', μ') ⤜ (λx. qbs_prob_space (Y', β', ν') ⤜ (λy. qbs_return (X' ⨂Q Y') (x, y)))"
        using h by(simp add: qbs_prob_space_eq 1)
      also have "... = ?rhs"
        by(simp add: pqp2.qbs_bind_return_pq)
      finally show ?thesis .
    qed
  qed
qed

lemma(in pair_qbs_probs) qbs_prob_pair_measure_computation:
  "(qbs_prob_space (X,α,μ)) ⨂Qmes (qbs_prob_space (Y,β,ν)) = qbs_prob_space (X ⨂Q Y, map_prod α β ∘ real_real.g , distr (μ ⨂M ν) real_borel real_real.f)"
  "qbs_prob (X ⨂Q Y) (map_prod α β ∘ real_real.g) (distr (μ ⨂M ν) real_borel real_real.f)"
  by(simp_all add: qbs_prob_pair_measure.abs_eq qbs_prob_pair_measure_t_def qbs_bind_return_pq)

lemma qbs_prob_pair_measure_qbs:
  "qbs_prob_space_qbs (p ⨂Qmes q) = qbs_prob_space_qbs p ⨂Q qbs_prob_space_qbs q"
  by(transfer,simp add: qbs_prob_pair_measure_t_def Let_def prod.case_eq_if)

lemma(in pair_qbs_probs) qbs_prob_pair_measure_measure:
    shows "qbs_prob_measure (qbs_prob_space (X,α,μ) ⨂Qmes qbs_prob_space (Y,β,ν)) = distr (μ ⨂M ν) (qbs_to_measure (X ⨂Q Y)) (map_prod α β)"
  by(simp add: qbs_prob_pair_measure_computation distr_distr comp_assoc)

lemma qbs_prob_pair_measure_morphism:
 "case_prod qbs_prob_pair_measure ∈ monadP_qbs X ⨂Q monadP_qbs Y →Q monadP_qbs (X ⨂Q Y)"
proof(rule pair_qbs_morphismI)
  fix βx βy
  assume h: "βx ∈ qbs_Mx (monadP_qbs X)" " βy ∈ qbs_Mx (monadP_qbs Y)"
  then obtain αx αy gx gy where ha:
   "αx ∈ qbs_Mx X" "gx ∈ real_borel →M prob_algebra real_borel" "βx = (λr. qbs_prob_space (X, αx, gx r))"
   "αy ∈ qbs_Mx Y" "gy ∈ real_borel →M prob_algebra real_borel" "βy = (λr. qbs_prob_space (Y, αy, gy r))"
    using rep_monadP_qbs_MPx[of βx X] rep_monadP_qbs_MPx[of βy Y] by auto
  note [measurable] = ha(2,5)
  have "(λ(x, y). x ⨂Qmes y) ∘ (λr. (βx r, βy r)) = (λr. qbs_prob_space (X ⨂Q Y, map_prod αx αy ∘ real_real.g, distr (gx r ⨂M gy r) real_borel real_real.f))"
    apply standard
    using qbs_prob_MPx[OF ha(1,2)] qbs_prob_MPx[OF ha(4,5)] pair_qbs_probs.qbs_prob_pair_measure_computation[of X αx _ Y αy]
    by (auto simp: ha pair_qbs_probs_def)
  also have "... ∈ qbs_Mx (monadP_qbs (X ⨂Q Y))"
    using qbs_prob_MPx[OF ha(1,2)] qbs_prob_MPx[OF ha(4,5)] pair_qbs_probs.ab_g_in_Mx[of X αx _ Y αy]
    by(auto intro!: bexI[where x="map_prod αx αy ∘ real_real.g"] bexI[where x="λr. distr (gx r ⨂M gy r) real_borel real_real.f"]
         simp: monadP_qbs_MPx_def in_MPx_def pair_qbs_probs_def)
  finally show "(λ(x, y). x ⨂Qmes y) ∘ (λr. (βx r, βy r)) ∈ qbs_Mx (monadP_qbs (X ⨂Q Y))" .
qed

lemma(in pair_qbs_probs) qbs_prob_pair_measure_nnintegral:
  assumes "f ∈ X ⨂Q Y →Q ℝQ≥0"
  shows "(∫+Q z. f z ∂(qbs_prob_space (X,α,μ) ⨂Qmes qbs_prob_space (Y,β,ν))) = (∫+ z. (f ∘ map_prod α β) z ∂(μ ⨂M ν))"
        (is "?lhs = ?rhs")
proof -
  have "?lhs = (∫+ x. ((f ∘ map_prod α β) ∘ real_real.g) x ∂distr (μ ⨂M ν) real_borel real_real.f)"
    by(simp add: qbs_prob_ennintegral_def[OF assms] qbs_prob_pair_measure_computation)
  also have "... = (∫+ x. ((f ∘ map_prod α β) ∘ real_real.g) (real_real.f x) ∂(μ ⨂M ν))"
    using assms by(intro nn_integral_distr) auto
  also have "... = ?rhs" by simp
  finally show ?thesis .
qed

lemma(in pair_qbs_probs) qbs_prob_pair_measure_integral:
  assumes "f ∈ X ⨂Q Y →Q ℝQ"
    shows "(∫Q z. f z ∂(qbs_prob_space (X,α,μ) ⨂Qmes qbs_prob_space (Y,β,ν))) = (∫z. (f ∘ map_prod α β) z ∂(μ ⨂M ν))"
          (is "?lhs = ?rhs")
proof -
  have "?lhs = (∫x. ((f ∘ map_prod α β) ∘ real_real.g) x ∂distr (μ ⨂M ν) real_borel real_real.f)"
    by(simp add: qbs_prob_integral_def[OF assms] qbs_prob_pair_measure_computation)
  also have "... = (∫ x. ((f ∘ map_prod α β) ∘ real_real.g) (real_real.f x) ∂(μ ⨂M ν))"
    using assms by(intro integral_distr) auto
  also have "... = ?rhs" by simp
  finally show ?thesis .
qed

lemma qbs_prob_pair_measure_eq_bind:
  assumes "p ∈ monadP_qbs_Px X"
      and "q ∈ monadP_qbs_Px Y"
    shows "p ⨂Qmes q = p ⤜ (λx. q ⤜ (λy. qbs_return (X ⨂Q Y) (x,y)))"
proof -
  obtain α μ where hp:
    "p = qbs_prob_space (X, α, μ)" "qbs_prob X α μ"
    using rep_monadP_qbs_Px[OF assms(1)] by auto
  obtain β ν where hq:
   "q = qbs_prob_space (Y, β, ν)" "qbs_prob Y β ν" 
    using rep_monadP_qbs_Px[OF assms(2)] by auto
  interpret pqp: pair_qbs_probs X α μ Y β ν
    by(simp add: pair_qbs_probs_def hp hq)
  show ?thesis
    by(simp add: hp(1) hq(1) pqp.qbs_prob_pair_measure_computation(1) pqp.qbs_bind_return_pq(1))
qed

subsubsection ‹Fubini Theorem›
lemma qbs_prob_ennintegral_Fubini_fst:
  assumes "p ∈ monadP_qbs_Px X"
          "q ∈ monadP_qbs_Px Y"
      and "f ∈ X ⨂Q Y →Q ℝQ≥0"
    shows "(∫+Q x. ∫+Q y. f (x,y) ∂q ∂p) = (∫+Q z. f z ∂(p ⨂Qmes q))"
          (is "?lhs = ?rhs")
proof -
  note [simp] = qbs_bind_morphism[OF qbs_morphism_const[of _ "monadP_qbs Y",simplified,OF assms(2)] curry_preserves_morphisms[OF qbs_return_morphism[of "X ⨂Q Y"]],simplified curry_def,simplified]
                qbs_morphism_Pair1'[OF _ qbs_return_morphism[of "X ⨂Q Y"]]
                assms(1)[simplified monadP_qbs_Px_def,simplified] assms(2)[simplified monadP_qbs_Px_def,simplified]
  have "?rhs = (∫+Q z. f z ∂(p ⤜ (λx. q ⤜ (λy. qbs_return (X ⨂Q Y) (x,y)))))"
    by(simp add: qbs_prob_pair_measure_eq_bind[OF assms(1,2)])
  also have "... = (∫+Q x. qbs_prob_ennintegral (q ⤜ (λy. qbs_return (X ⨂Q Y) (x, y))) f ∂p)"
    by(auto intro!: qbs_prob_ennintegral_bind[OF assms(1) _ assms(3)])
  also have "... =  (∫+Q x. ∫+Q y. qbs_prob_ennintegral (qbs_return (X ⨂Q Y) (x, y)) f ∂q ∂p)"
    by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_bind[OF assms(2) _ assms(3)])
  also have "... = ?lhs"
    using assms(3) by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_return)
  finally show ?thesis by simp
qed

lemma qbs_prob_ennintegral_Fubini_snd:
  assumes "p ∈ monadP_qbs_Px X"
          "q ∈ monadP_qbs_Px Y"
      and "f ∈ X ⨂Q Y →Q ℝQ≥0"
    shows "(∫+Q y. ∫+Q x. f (x,y) ∂p ∂q) = (∫+Q x. f x ∂(p ⨂Qmes q))"
          (is "?lhs = ?rhs")
proof -
  note [simp] = qbs_bind_morphism[OF qbs_morphism_const[of _ "monadP_qbs X",simplified,OF assms(1)] curry_preserves_morphisms[OF qbs_morphism_pair_swap[OF qbs_return_morphism[of "X ⨂Q Y"]],simplified curry_def,simplified]]
                qbs_morphism_Pair2'[OF _ qbs_return_morphism[of "X ⨂Q Y"]]
                assms(1)[simplified monadP_qbs_Px_def,simplified] assms(2)[simplified monadP_qbs_Px_def,simplified]
  have "?rhs = (∫+Q z. f z ∂(q ⤜ (λy. p ⤜ (λx. qbs_return (X ⨂Q Y) (x,y)))))"
    by(simp add: qbs_prob_pair_measure_eq_bind[OF assms(1,2)] qbs_bind_return_rotate[OF assms(1,2)])
  also have "... = (∫+Q y. qbs_prob_ennintegral (p ⤜ (λx. qbs_return (X ⨂Q Y) (x, y))) f ∂q)"
    by(auto intro!: qbs_prob_ennintegral_bind[OF assms(2) _ assms(3)])
  also have "... =  (∫+Q y. ∫+Q x. qbs_prob_ennintegral (qbs_return (X ⨂Q Y) (x, y)) f ∂p ∂q)"
    by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_bind[OF assms(1) _ assms(3)])
  also have "... = ?lhs"
    using assms(3) by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_return)
  finally show ?thesis by simp
qed

lemma qbs_prob_ennintegral_indep1:
  assumes "p ∈ monadP_qbs_Px X"
      and "f ∈ X →Q ℝQ≥0"
    shows "(∫+Q z. f (fst z) ∂(p ⨂Qmes q)) = (∫+Q x. f x ∂p)"
          (is "?lhs = _")
proof -
 obtain Y β ν where hq:
   "q = qbs_prob_space (Y, β, ν)" "qbs_prob Y β ν" 
    using rep_qbs_prob_space[of q] by auto
  have "?lhs = (∫+Q y. ∫+Q x. f x ∂p ∂q)"
    using qbs_prob_ennintegral_Fubini_snd[OF assms(1) qbs_prob.qbs_prob_space_in_Px[OF hq(2)] qbs_morphism_fst''[OF assms(2)]]
    by(simp add: hq(1))
  thus ?thesis
    by(simp add: qbs_prob_ennintegral_const)
qed

lemma qbs_prob_ennintegral_indep2:
  assumes "q ∈ monadP_qbs_Px Y"
      and "f ∈ Y →Q ℝQ≥0"
    shows "(∫+Q z. f (snd z) ∂(p ⨂Qmes q)) = (∫+Q y. f y ∂q)"
          (is "?lhs = _")
proof -
  obtain X α μ where hp:
    "p = qbs_prob_space (X, α, μ)" "qbs_prob X α μ"
    using rep_qbs_prob_space[of p] by auto
  have "?lhs = (∫+Q x. ∫+Q y. f y ∂q ∂p)"
    using qbs_prob_ennintegral_Fubini_fst[OF qbs_prob.qbs_prob_space_in_Px[OF hp(2)] assms(1) qbs_morphism_snd''[OF assms(2)]]
    by(simp add: hp(1))
  thus ?thesis
    by(simp add: qbs_prob_ennintegral_const)
qed

lemma qbs_ennintegral_indep_mult:
  assumes "p ∈ monadP_qbs_Px X"
          "q ∈ monadP_qbs_Px Y"
          "f ∈ X →Q ℝQ≥0"
      and "g ∈ Y →Q ℝQ≥0"
    shows "(∫+Q z. f (fst z) * g (snd z) ∂(p ⨂Qmes q)) = (∫+Q x. f x ∂p) * (∫+Q y. g y ∂q)"
          (is "?lhs = ?rhs")
proof -
  have h:"(λz. f (fst z) * g (snd z)) ∈ X ⨂Q Y →Q ℝQ≥0"
    using assms(4,3) 
    by(auto intro!: borel_measurable_subalgebra[OF l_product_sets[of X Y]] simp: space_pair_measure lr_adjunction_correspondence)

  have "?lhs = (∫+Q x. ∫+Q y .f x * g y ∂q ∂p)"
    using qbs_prob_ennintegral_Fubini_fst[OF assms(1,2) h] by simp
  also have "... = (∫+Q x. f x * ∫+Q y . g y ∂q ∂p)"
    using qbs_prob_ennintegral_cmult[of q,OF _ assms(4)] assms(2)
    by(simp add: monadP_qbs_Px_def)
  also have "... = ?rhs"
    using qbs_prob_ennintegral_cmult[of p,OF _ assms(3)] assms(1)
    by(simp add: ab_semigroup_mult_class.mult.commute[where b="qbs_prob_ennintegral q g"] monadP_qbs_Px_def)
  finally show ?thesis .
qed


lemma(in pair_qbs_probs) qbs_prob_pair_measure_integrable:
  assumes "qbs_integrable (qbs_prob_space (X,α,μ) ⨂Qmes qbs_prob_space (Y,β,ν)) f"
    shows "f ∈ X ⨂Q Y →Q ℝQ"
          "integrable (μ ⨂M ν) (f ∘ (map_prod α β))"
proof -
  show "f ∈ X ⨂Q Y →Q ℝQ"
    using qbs_integrable_morphism[OF qbs_prob_pair_measure_qbs assms]
    by simp
next
  have 1:"integrable (distr (μ ⨂M ν) real_borel real_real.f) (f ∘ (map_prod α β ∘ real_real.g))"
    using assms[simplified qbs_prob_pair_measure_computation] qbs_integrable_def[of f]
    by simp
  have "integrable (μ ⨂M ν) (λx. (f ∘ (map_prod α β ∘ real_real.g)) (real_real.f x))"
    by(intro integrable_distr[OF _ 1]) simp
  thus "integrable (μ ⨂M ν) (f ∘ map_prod α β)"
    by(simp add: comp_def)
qed

lemma(in pair_qbs_probs) qbs_prob_pair_measure_integrable':
  assumes "f ∈ X ⨂Q Y →Q ℝQ"
      and "integrable (μ ⨂M ν) (f ∘ (map_prod α β))"
    shows "qbs_integrable (qbs_prob_space (X,α,μ) ⨂Qmes qbs_prob_space (Y,β,ν)) f" 
proof -
  have "integrable (distr (μ ⨂M ν) real_borel real_real.f) (f ∘ (map_prod α β ∘ real_real.g)) = integrable (μ ⨂M ν) (λx. (f ∘ (map_prod α β ∘ real_real.g)) (real_real.f x))"
    by(intro integrable_distr_eq) (use assms(1) in auto)
  thus ?thesis
    using assms qbs_integrable_def
    by(simp add: comp_def qbs_prob_pair_measure_computation)
qed

lemma qbs_integrable_pair_swap:
  assumes "qbs_integrable (p ⨂Qmes q) f"
  shows "qbs_integrable (q ⨂Qmes p) (λ(x,y). f (y,x))"
proof -
  obtain X α μ where hp:
    "p = qbs_prob_space (X, α, μ)" "qbs_prob X α μ"
    using rep_qbs_prob_space[of p] by auto
  obtain Y β ν where hq:
   "q = qbs_prob_space (Y, β, ν)" "qbs_prob Y β ν" 
    using rep_qbs_prob_space[of q] by auto
  interpret pqp: pair_qbs_probs X α μ Y β ν
    by(simp add: pair_qbs_probs_def hp hq)
  interpret pqp2: pair_qbs_probs Y β ν X α μ
    by(simp add: pair_qbs_probs_def hp hq)
 
  have "f ∈ X ⨂Q Y →Q ℝQ"
       "integrable (μ ⨂M ν) (f ∘ map_prod α β)"
    by(auto simp: pqp.qbs_prob_pair_measure_integrable[OF assms[simplified hp(1) hq(1)]])
  from qbs_morphism_pair_swap[OF this(1)] pqp.integrable_product_swap[OF this(2)]
  have "(λ(x,y). f (y,x)) ∈ Y ⨂Q X →Q ℝQ"
        "integrable (ν ⨂M μ) ((λ(x,y). f (y,x)) ∘ map_prod β α)"
    by(simp_all add: map_prod_def comp_def split_beta')
  from pqp2.qbs_prob_pair_measure_integrable' [OF this]
  show ?thesis by(simp add: hp(1) hq(1))
qed

lemma qbs_integrable_pair1:
  assumes "p ∈ monadP_qbs_Px X"
          "q ∈ monadP_qbs_Px Y"
          "f ∈ X ⨂Q Y →Q ℝQ"
          "qbs_integrable p (λx. ∫Q y. ¦f (x,y)¦ ∂q)"
      and "⋀x. x ∈ qbs_space X ⟹ qbs_integrable q (λy. f (x,y))"
    shows "qbs_integrable (p ⨂Qmes q) f"
proof -
  obtain α μ where hp:
    "p = qbs_prob_space (X, α, μ)" "qbs_prob X α μ"
    using rep_monadP_qbs_Px[OF assms(1)] by auto
  obtain β ν where hq:
   "q = qbs_prob_space (Y, β, ν)" "qbs_prob Y β ν" 
    using rep_monadP_qbs_Px[OF assms(2)] by auto
  interpret pqp: pair_qbs_probs X α μ Y β ν
    by(simp add: pair_qbs_probs_def hp hq)

  have "integrable (μ ⨂M ν) (f ∘ map_prod α β)"
  proof(rule pqp.Fubini_integrable)
    show "f ∘ map_prod α β ∈ borel_measurable (μ ⨂M ν)"
      using assms(3) by auto
  next
    have "(λx. LINT y|ν. norm ((f ∘ map_prod α β) (x, y))) = (λx. ∫Q y. ¦f (x,y)¦ ∂q) ∘ α"
      apply standard subgoal for x
        using qbs_morphism_Pair1'[OF qbs_Mx_to_X(2)[OF pqp.qp1.in_Mx,of x] assms(3)]
        by(auto intro!: pqp.qp2.qbs_prob_integral_def[symmetric] simp: hq(1))
      done
    moreover have "integrable μ ..."
      using assms(4) pqp.qp1.qbs_integrable_def
      by (simp add: hp(1))
    ultimately show "integrable μ (λx. LINT y|ν. norm ((f ∘ map_prod α β) (x, y)))"
      by simp
  next
    have "⋀x. integrable ν (λy. (f ∘ map_prod α β) (x, y))"
    proof-
      fix x
      have "(λy. (f ∘ map_prod α β) (x, y)) = (λy. f (α x,y)) ∘ β"
        by auto
      moreover have "qbs_integrable (qbs_prob_space (Y, β, ν)) (λy. f (α x, y))"
        by(auto intro!: assms(5)[simplified hq(1)] simp: qbs_Mx_to_X)
      ultimately show "integrable ν (λy. (f ∘ map_prod α β) (x, y))"
        by(simp add: pqp.qp2.qbs_integrable_def)
    qed
    thus "AE x in μ. integrable ν (λy. (f ∘ map_prod α β) (x, y))"
      by simp
  qed
  thus ?thesis
    using pqp.qbs_prob_pair_measure_integrable'[OF assms(3)]
    by(simp add: hp(1) hq(1))
qed

lemma qbs_integrable_pair2:
  assumes "p ∈ monadP_qbs_Px X"
          "q ∈ monadP_qbs_Px Y"
          "f ∈ X ⨂Q Y →Q ℝQ"
          "qbs_integrable q (λy. ∫Q x. ¦f (x,y)¦ ∂p)"
      and "⋀y. y ∈ qbs_space Y ⟹ qbs_integrable p (λx. f (x,y))"
    shows "qbs_integrable (p ⨂Qmes q) f"
  using qbs_integrable_pair_swap[OF qbs_integrable_pair1[OF assms(2,1) qbs_morphism_pair_swap[OF assms(3)],simplified,OF assms(4,5)]]
  by simp

lemma qbs_integrable_fst:
  assumes "qbs_integrable (p ⨂Qmes q) f"
  shows "qbs_integrable p (λx. ∫Q y. f (x,y) ∂q)"
proof -
  obtain X α μ where hp:
    "p = qbs_prob_space (X, α, μ)" "qbs_prob X α μ"
    using rep_qbs_prob_space[of p] by auto
  obtain Y β ν where hq:
   "q = qbs_prob_space (Y, β, ν)" "qbs_prob Y β ν" 
    using rep_qbs_prob_space[of q] by auto
  interpret pqp: pair_qbs_probs X α μ Y β ν
    by(simp add: hp hq  pair_qbs_probs_def)
  have h0: "p ∈ monadP_qbs_Px X" "q ∈ monadP_qbs_Px Y" "f ∈ X ⨂Q Y →Q ℝQ"
    using qbs_integrable_morphism[OF _ assms,simplified qbs_prob_pair_measure_qbs]
    by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))

  show "qbs_integrable p (λx. ∫Q y. f (x, y) ∂q)"
  proof(auto simp add: pqp.qp1.qbs_integrable_def hp(1))
    show "(λx. ∫Q y. f (x, y) ∂q) ∈ borel_measurable (qbs_to_measure X)"
      using qbs_morphism_integral_fst[OF h0(2,3)] by auto
  next
    have "integrable μ (λx. LINT y|ν. (f ∘ map_prod α β) (x, y))"
      by(intro pqp.integrable_fst') (rule pqp.qbs_prob_pair_measure_integrable(2)[OF assms[simplified hp(1) hq(1)]])
    moreover have "⋀x. ((λx. ∫Q y. f (x, y) ∂q) ∘ α) x = LINT y|ν. (f ∘ map_prod α β) (x, y)"
     by(auto intro!: pqp.qp2.qbs_prob_integral_def qbs_morphism_Pair1'[OF qbs_Mx_to_X(2)[OF pqp.qp1.in_Mx] h0(3)] simp: hq)
    ultimately show "integrable μ ((λx. ∫Q y. f (x, y) ∂q) ∘ α)"
      using integrable_cong[of μ μ "(λx. ∫Q y. f (x, y) ∂q) ∘ α" " (λx. LINT y|ν. (f ∘ map_prod α β) (x, y))"]
      by simp
  qed
qed

lemma qbs_integrable_snd:
  assumes "qbs_integrable (p ⨂Qmes q) f"
  shows "qbs_integrable q (λy. ∫Q x. f (x,y) ∂p)"
  using qbs_integrable_fst[OF qbs_integrable_pair_swap[OF assms]]
  by simp

lemma qbs_integrable_indep_mult:
  assumes "qbs_integrable p f"
      and "qbs_integrable q g"
    shows "qbs_integrable (p ⨂Qmes q) (λx. f (fst x) * g (snd x))"
proof -
  obtain X α μ where hp:
    "p = qbs_prob_space (X, α, μ)" "qbs_prob X α μ"
    using rep_qbs_prob_space[of p] by auto
  obtain Y β ν where hq:
   "q = qbs_prob_space (Y, β, ν)" "qbs_prob Y β ν" 
    using rep_qbs_prob_space[of q] by auto
  interpret pqp: pair_qbs_probs X α μ Y β ν
    by(simp add: hp hq  pair_qbs_probs_def)
  have h0: "p ∈ monadP_qbs_Px X" "q ∈ monadP_qbs_Px Y" "f ∈ X →Q ℝQ" "g ∈ Y →Q ℝQ"
    using qbs_integrable_morphism[OF _ assms(1)] qbs_integrable_morphism[OF _ assms(2)]
    by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))

  show ?thesis
  proof(rule qbs_integrable_pair1[OF h0(1,2)],simp_all add: assms(2))
    show "(λz. f (fst z) * g (snd z)) ∈  X ⨂Q Y →Q ℝQ"
      using h0(3,4) by(auto intro!: borel_measurable_subalgebra[OF l_product_sets[of X Y]] simp: space_pair_measure lr_adjunction_correspondence)
  next
    show "qbs_integrable p (λx. ∫Q y. ¦f x * g y¦ ∂q)"
      by(auto intro!: qbs_integrable_mult[OF qbs_integrable_abs[OF assms(1)]]
           simp only: idom_abs_sgn_class.abs_mult qbs_prob_integral_cmult ab_semigroup_mult_class.mult.commute[where b="∫Q y. ¦g y¦ ∂q"])
  qed
qed

lemma qbs_integrable_indep1:
  assumes "qbs_integrable p f"
  shows "qbs_integrable (p ⨂Qmes q) (λx. f (fst x))"
  using qbs_integrable_indep_mult[OF assms qbs_integrable_const[of q 1]]
  by simp

lemma qbs_integrable_indep2:
  assumes "qbs_integrable q g"
  shows "qbs_integrable (p ⨂Qmes q) (λx. g (snd x))"
  using qbs_integrable_pair_swap[OF qbs_integrable_indep1[OF assms],of p]
  by(simp add: split_beta')


lemma qbs_prob_integral_Fubini_fst:
  assumes "qbs_integrable (p ⨂Qmes q) f"
    shows "(∫Q x. ∫Q y. f (x,y) ∂q ∂p) = (∫Q z. f z ∂(p ⨂Qmes q))"
          (is "?lhs = ?rhs")
proof -
  obtain X α μ where hp:
    "p = qbs_prob_space (X, α, μ)" "qbs_prob X α μ"
    using rep_qbs_prob_space[of p] by auto
  obtain Y β ν where hq:
   "q = qbs_prob_space (Y, β, ν)" "qbs_prob Y β ν" 
    using rep_qbs_prob_space[of q] by auto
  interpret pqp: pair_qbs_probs X α μ Y β ν
    by(simp add: hp hq  pair_qbs_probs_def)
  have h0: "p ∈ monadP_qbs_Px X" "q ∈ monadP_qbs_Px Y" "f ∈ X ⨂Q Y →Q ℝQ"
    using qbs_integrable_morphism[OF _ assms,simplified qbs_prob_pair_measure_qbs]
    by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))

  have "?lhs = (∫ x. ∫Q y. f (α x, y) ∂q ∂μ)"
    using qbs_morphism_integral_fst[OF h0(2) h0(3)]
    by(auto intro!: pqp.qp1.qbs_prob_integral_def simp: hp(1))
  also have "... = (∫x. ∫y. f (α x, β y) ∂ν ∂μ)"
    using qbs_morphism_Pair1'[OF qbs_Mx_to_X(2)[OF pqp.qp1.in_Mx] h0(3)]
    by(auto intro!: Bochner_Integration.integral_cong pqp.qp2.qbs_prob_integral_def
              simp: hq(1))
  also have "... = (∫z. (f ∘ map_prod α β) z ∂(μ ⨂M ν))"
    using pqp.integral_fst'[OF pqp.qbs_prob_pair_measure_integrable(2)[OF assms[simplified hp(1) hq(1)]]]
    by(simp add: map_prod_def comp_def)
  also have "... = ?rhs"
    by(simp add: pqp.qbs_prob_pair_measure_integral[OF h0(3)] hp(1) hq(1))
  finally show ?thesis .
qed

lemma qbs_prob_integral_Fubini_snd:
  assumes "qbs_integrable (p ⨂Qmes q) f"
    shows "(∫Q y. ∫Q x. f (x,y) ∂p ∂q) = (∫Q z. f z ∂(p ⨂Qmes q))"
          (is "?lhs = ?rhs")
proof -
  obtain X α μ where hp:
    "p = qbs_prob_space (X, α, μ)" "qbs_prob X α μ"
    using rep_qbs_prob_space[of p] by auto
  obtain Y β ν where hq:
   "q = qbs_prob_space (Y, β, ν)" "qbs_prob Y β ν" 
    using rep_qbs_prob_space[of q] by auto
  interpret pqp: pair_qbs_probs X α μ Y β ν
    by(simp add: hp hq  pair_qbs_probs_def)
  have h0: "p ∈ monadP_qbs_Px X" "q ∈ monadP_qbs_Px Y" "f ∈ X ⨂Q Y →Q ℝQ"
    using qbs_integrable_morphism[OF _ assms,simplified qbs_prob_pair_measure_qbs]
    by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))

  have "?lhs = (∫ y. ∫Q x. f (x,β y) ∂p ∂ν)"
    using qbs_morphism_integral_snd[OF h0(1) h0(3)]
    by(auto intro!: pqp.qp2.qbs_prob_integral_def simp: hq(1))
  also have "... = (∫y. ∫x. f (α x, β y) ∂μ ∂ν)"
    using qbs_morphism_Pair2'[OF qbs_Mx_to_X(2)[OF pqp.qp2.in_Mx] h0(3)]
    by(auto intro!: Bochner_Integration.integral_cong pqp.qp1.qbs_prob_integral_def
              simp: hp(1))
  also have "... = (∫z. (f ∘ map_prod α β) z ∂(μ ⨂M ν))"
    using pqp.integral_snd[of "curry (f ∘ map_prod α β)"] pqp.qbs_prob_pair_measure_integrable(2)[OF assms[simplified hp(1) hq(1)]]
    by(simp add: map_prod_def comp_def split_beta')
  also have "... = ?rhs"
    by(simp add: pqp.qbs_prob_pair_measure_integral[OF h0(3)] hp(1) hq(1))
  finally show ?thesis .
qed

lemma qbs_prob_integral_indep1:
  assumes "qbs_integrable p f"
  shows "(∫Q z. f (fst z) ∂(p ⨂Qmes q)) = (∫Q x. f x ∂p)"
  using qbs_prob_integral_Fubini_snd[OF qbs_integrable_indep1[OF assms],of q]
  by(simp add: qbs_prob_integral_const)

lemma qbs_prob_integral_indep2:
  assumes "qbs_integrable q g"
  shows "(∫Q z. g (snd z) ∂(p ⨂Qmes q)) = (∫Q y. g y ∂q)"
  using qbs_prob_integral_Fubini_fst[OF qbs_integrable_indep2[OF assms],of p]
  by(simp add: qbs_prob_integral_const)

lemma qbs_prob_integral_indep_mult:
  assumes "qbs_integrable p f"
      and "qbs_integrable q g"
    shows "(∫Q z. f (fst z) * g (snd z) ∂(p ⨂Qmes q)) = (∫Q x. f x ∂p) * (∫Q y. g y ∂q)"
          (is "?lhs = ?rhs")
proof -
  have "?lhs = (∫Q x. ∫Q y. f x * g y ∂q ∂p)"
    using qbs_prob_integral_Fubini_fst[OF qbs_integrable_indep_mult[OF assms]]
    by simp
  also have "... = (∫Q x. f x * (∫Q y.  g y ∂q) ∂p)"
    by(simp add: qbs_prob_integral_cmult)
  also have "... = ?rhs"
    by(simp add: qbs_prob_integral_cmult ab_semigroup_mult_class.mult.commute[where b="∫Q y.  g y ∂q"])
  finally show ?thesis .
qed

lemma qbs_prob_var_indep_plus:
  assumes "qbs_integrable (p ⨂Qmes q) f"
          "qbs_integrable (p ⨂Qmes q) (λz. (f z)2)"
          "qbs_integrable (p ⨂Qmes q) g"
          "qbs_integrable (p ⨂Qmes q) (λz. (g z)2)"
          "qbs_integrable (p ⨂Qmes q) (λz. (f z) * (g z))"
      and "(∫Q z. f z * g z ∂(p ⨂Qmes q)) = (∫Q z. f z ∂(p ⨂Qmes q)) * (∫Q z. g z ∂(p ⨂Qmes q))"
    shows "qbs_prob_var (p ⨂Qmes q) (λz. f z + g z) = qbs_prob_var (p ⨂Qmes q) f + qbs_prob_var (p ⨂Qmes q) g"
  unfolding qbs_prob_var_def
proof -
  show "(∫Q z. (f z + g z - ∫Q w. f w + g w ∂(p ⨂Qmes q))2 ∂(p ⨂Qmes q)) = (∫Q z. (f z - qbs_prob_integral (p ⨂Qmes q) f)2 ∂(p ⨂Qmes q)) + (∫Q z. (g z - qbs_prob_integral (p ⨂Qmes q) g)2 ∂(p ⨂Qmes q))"
       (is "?lhs = ?rhs")
  proof -
    have "?lhs = (∫Q z. ((f z - (∫Q w. f w ∂(p ⨂Qmes q))) + (g z - (∫Q w. g w ∂(p ⨂Qmes q))))2 ∂(p ⨂Qmes q))"
      by(simp add: qbs_prob_integral_add[OF assms(1,3)] add_diff_add)
    also have "... = (∫Q z. (f z - (∫Q w. f w ∂(p ⨂Qmes q)))2 + (g z - (∫Q w. g w ∂(p ⨂Qmes q)))2 + (2 * f z * g z - 2 * (∫Q w. f w ∂(p ⨂Qmes q)) * g z - (2 * f z * (∫Q w. g w ∂(p ⨂Qmes q)) - 2 * (∫Q w. f w ∂(p ⨂Qmes q)) * (∫Q w. g w ∂(p ⨂Qmes q)))) ∂(p ⨂Qmes q))"
      by(simp add: comm_semiring_1_class.power2_sum comm_semiring_1_cancel_class.left_diff_distrib' ring_class.right_diff_distrib)
    also have "... = ?rhs"
      using qbs_prob_integral_add[OF qbs_integrable_add[OF qbs_integrable_sq[OF assms(1,2)] qbs_integrable_sq[OF assms(3,4)]] qbs_integrable_diff[OF qbs_integrable_diff[OF qbs_integrable_mult[OF assms(5),of 2,simplified comm_semiring_1_class.semiring_normalization_rules(18)] qbs_integrable_mult[OF assms(3),of "2 * qbs_prob_integral (p ⨂Qmes q) f"]] qbs_integrable_diff[OF qbs_integrable_mult[OF assms(1),of "2 * qbs_prob_integral (p ⨂Qmes q) g",simplified ab_semigroup_mult_class.mult_ac(1)[where b="qbs_prob_integral (p ⨂Qmes q) g"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p ⨂Qmes q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of _ _ "qbs_prob_integral (p ⨂Qmes q) g"]] qbs_integrable_const[of _ "2 * qbs_prob_integral (p ⨂Qmes q) f * qbs_prob_integral (p ⨂Qmes q) g"]]]]
            qbs_prob_integral_add[OF qbs_integrable_sq[OF assms(1,2)] qbs_integrable_sq[OF assms(3,4)]]
            qbs_prob_integral_diff[OF qbs_integrable_diff[OF qbs_integrable_mult[OF assms(5),of 2,simplified comm_semiring_1_class.semiring_normalization_rules(18)] qbs_integrable_mult[OF assms(3),of "2 * qbs_prob_integral (p ⨂Qmes q) f"]] qbs_integrable_diff[OF qbs_integrable_mult[OF assms(1),of "2 * qbs_prob_integral (p ⨂Qmes q) g",simplified ab_semigroup_mult_class.mult_ac(1)[where b="qbs_prob_integral (p ⨂Qmes q) g"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p ⨂Qmes q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of _ _ "qbs_prob_integral (p ⨂Qmes q) g"]] qbs_integrable_const[of _ "2 * qbs_prob_integral (p ⨂Qmes q) f * qbs_prob_integral (p ⨂Qmes q) g"]]]
            qbs_prob_integral_diff[OF qbs_integrable_mult[OF assms(5),of 2,simplified comm_semiring_1_class.semiring_normalization_rules(18)] qbs_integrable_mult[OF assms(3),of "2 * qbs_prob_integral (p ⨂Qmes q) f"]]
            qbs_prob_integral_diff[OF qbs_integrable_mult[OF assms(1),of "2 * qbs_prob_integral (p ⨂Qmes q) g",simplified ab_semigroup_mult_class.mult_ac(1)[where b="qbs_prob_integral (p ⨂Qmes q) g"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p ⨂Qmes q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of _ _ "qbs_prob_integral (p ⨂Qmes q) g"]] qbs_integrable_const[of _ "2 * qbs_prob_integral (p ⨂Qmes q) f * qbs_prob_integral (p ⨂Qmes q) g"]]
            qbs_prob_integral_cmult[of "p ⨂Qmes q" 2 "λz. f z * g z",simplified assms(6) comm_semiring_1_class.semiring_normalization_rules(18)]
            qbs_prob_integral_cmult[of "p ⨂Qmes q" "2 * (∫Q w. f w ∂(p ⨂Qmes q))" g]
            qbs_prob_integral_cmult[of "p ⨂Qmes q" "2 * (∫Q w. g w ∂(p ⨂Qmes q))" f,simplified semigroup_mult_class.mult.assoc[of 2 "∫Q w. g w ∂(p ⨂Qmes q)"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p ⨂Qmes q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of 2 _ "∫Q w. g w ∂(p ⨂Qmes q)"]]
            qbs_prob_integral_const[of "p ⨂Qmes q" "2 * qbs_prob_integral (p ⨂Qmes q) f * qbs_prob_integral (p ⨂Qmes q) g"]
      by simp
    finally show ?thesis .
  qed
qed

lemma qbs_prob_var_indep_plus':
  assumes "qbs_integrable p f"
          "qbs_integrable p (λx. (f x)2)"
          "qbs_integrable q g"
      and "qbs_integrable q (λx. (g x)2)"
    shows "qbs_prob_var (p ⨂Qmes q) (λz. f (fst z) + g (snd z)) = qbs_prob_var p f + qbs_prob_var q g"
  using qbs_prob_var_indep_plus[OF qbs_integrable_indep1[OF assms(1)] qbs_integrable_indep1[OF assms(2)] qbs_integrable_indep2[OF assms(3)] qbs_integrable_indep2[OF assms(4)] qbs_integrable_indep_mult[OF assms(1) assms(3)] qbs_prob_integral_indep_mult[OF assms(1) assms(3),simplified  qbs_prob_integral_indep1[OF assms(1),of q,symmetric] qbs_prob_integral_indep2[OF assms(3),of p,symmetric]]]
        qbs_prob_integral_indep1[OF qbs_integrable_sq[OF assms(1,2)],of q "∫Q z. f (fst z) ∂(p ⨂Qmes q)"] qbs_prob_integral_indep2[OF qbs_integrable_sq[OF assms(3,4)],of p "∫Q z. g (snd z) ∂(p ⨂Qmes q)"]
  by(simp add: qbs_prob_var_def qbs_prob_integral_indep1[OF assms(1)] qbs_prob_integral_indep2[OF assms(3)])

end
le>

Theory Measure_as_QuasiBorel_Measure

(*  Title:   Measure_as_QuasiBorel_Measure.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsection ‹ Measure as QBS Measure›
theory Measure_as_QuasiBorel_Measure
  imports "Pair_QuasiBorel_Measure"

begin

lemma distr_id':
  assumes "sets N = sets M"
          "f ∈ N →M N"
      and "⋀x. x ∈ space N ⟹ f x = x"
    shows "distr N M f = N"
proof(rule measure_eqI)
  fix A
  assume 0:"A ∈ sets (distr N M f)"
  then have 1:"A ⊆ space N"
    by (auto simp: assms(1) sets.sets_into_space)

  have 2:"A ∈ sets M"
    using 0 by simp
  have 3:"f ∈ N →M M"
    using assms(2) by(simp add: measurable_cong_sets[OF _ assms(1)])
  have "f -` A ∩ space N = A"
  proof -
    have "f -` A = A ∪ {x. x ∉ space N ∧ f x ∈ A}"
    proof(standard;standard)
      fix x
      assume h:"x ∈ f -` A"
      consider "x ∈ A" | "x ∉ A"
        by auto
      thus "x ∈ A ∪ {x. x ∉ space N ∧ f x ∈ A}"
      proof cases
        case 1
        then show ?thesis
          by simp
      next
        case 2
        have "x ∉ space N"
        proof(rule ccontr)
          assume "¬ x ∉ space N"
          then have "x ∈ space N"
            by simp
          hence "f x = x"
            by(simp add: assms(3))
          hence "f x ∉ A"
            by(simp add: 2)
          thus False
            using h by simp
        qed
        thus ?thesis
          using h by simp
      qed
    next
      fix x
      show "x ∈ A ∪ {x. x ∉ space N ∧ f x ∈ A} ⟹ x ∈ f -` A"
        using 1 assms by auto
    qed
    thus ?thesis
      using "1" by blast
  qed
  thus "emeasure (distr N M f) A = emeasure N A"
    by(simp add: emeasure_distr[OF 3 2])
qed (simp add: assms(1))

text ‹ Every probability measure on a standard Borel space can be represented as a measure on
       a quasi-Borel space~\cite{Heunen_2017}, Proposition 23.›
locale standard_borel_prob_space = standard_borel P + p:prob_space P
  for P :: "'a measure"
begin

sublocale qbs_prob "measure_to_qbs P" g "distr P real_borel f"
  by(auto intro!: qbs_probI p.prob_space_distr)

lift_definition as_qbs_measure :: "'a qbs_prob_space" is
"(measure_to_qbs P, g, distr P real_borel f)"
  by simp

lemma as_qbs_measure_retract:
  assumes [measurable]:"a ∈ P →M real_borel"
      and [measurable]:"b ∈ real_borel →M P"
      and [simp]:"⋀x. x ∈ space P ⟹ (b ∘ a) x = x"
    shows "qbs_prob (measure_to_qbs P) b (distr P real_borel a)"
          "as_qbs_measure = qbs_prob_space (measure_to_qbs P, b, distr P real_borel a)"
proof -
  interpret pqp: pair_qbs_prob "measure_to_qbs P" g "distr P real_borel f" "measure_to_qbs P" b "distr P real_borel a"
    by(auto intro!: qbs_probI p.prob_space_distr simp: pair_qbs_prob_def)
  show "qbs_prob (measure_to_qbs P) b (distr P real_borel a)"
       "as_qbs_measure = qbs_prob_space (measure_to_qbs P, b, distr P real_borel a)"
    by(auto intro!: pqp.qbs_prob_space_eq
          simp: distr_distr distr_id'[OF standard_borel_lr_sets_ident[symmetric]] distr_id'[OF standard_borel_lr_sets_ident[symmetric] _ assms(3)] pqp.qp2.qbs_prob_axioms as_qbs_measure.abs_eq)
qed

lemma measure_as_qbs_measure_qbs:
 "qbs_prob_space_qbs as_qbs_measure = measure_to_qbs P"
  by transfer auto

lemma measure_as_qbs_measure_image:
 "as_qbs_measure ∈ monadP_qbs_Px (measure_to_qbs P)"
  by(auto simp: measure_as_qbs_measure_qbs monadP_qbs_Px_def)

lemma as_qbs_measure_as_measure[simp]:
 "distr (distr P real_borel f) (qbs_to_measure (measure_to_qbs P)) g = P"
  by(auto intro!: distr_id'[OF standard_borel_lr_sets_ident[symmetric]] simp : qbs_prob_t_measure_def distr_distr )


lemma measure_as_qbs_measure_recover:
 "qbs_prob_measure as_qbs_measure = P"
  by transfer (simp add: qbs_prob_t_measure_def)

end

lemma(in standard_borel) qbs_prob_measure_recover:
  assumes "q ∈ monadP_qbs_Px (measure_to_qbs M)"
  shows "standard_borel_prob_space.as_qbs_measure (qbs_prob_measure q) = q"
proof -
  obtain α μ where hq:
  "q = qbs_prob_space (measure_to_qbs M, α, μ)" "qbs_prob (measure_to_qbs M) α μ"
    using rep_monadP_qbs_Px[OF assms] by auto
  then interpret qp: qbs_prob "measure_to_qbs M" α μ by simp
  interpret sp: standard_borel_prob_space "distr μ (qbs_to_measure (measure_to_qbs M)) α"
    using qp.in_Mx
    by(auto intro!: prob_space.prob_space_distr
           simp: standard_borel_prob_space_def standard_borel_sets[OF sets_distr[of μ "qbs_to_measure (measure_to_qbs M)" α,simplified standard_borel_lr_sets_ident,symmetric]])
  interpret st: standard_borel "distr μ M α"
    by(auto intro!: standard_borel_sets)
  have [measurable]:"st.g ∈ real_borel →M M"
    using measurable_distr_eq2 st.g_meas by blast
  show ?thesis
    by(auto intro!: pair_qbs_prob.qbs_prob_space_eq
          simp add: hq(1) sp.as_qbs_measure.abs_eq pair_qbs_prob_def qp.qbs_prob_axioms sp.qbs_prob_axioms)
     (simp_all add: measure_to_qbs_cong_sets[OF sets_distr[of μ "qbs_to_measure (measure_to_qbs M)" α,simplified standard_borel_lr_sets_ident]])
qed

lemma(in standard_borel_prob_space) ennintegral_as_qbs_ennintegral:
  assumes "k ∈ borel_measurable P"
  shows "(∫+Q x. k x ∂as_qbs_measure) = (∫+ x. k x ∂P)"
proof -
  have 1:"k ∈ measure_to_qbs P →Q ℝQ≥0"
    using assms by auto
  thus ?thesis
    by(simp add: as_qbs_measure.abs_eq qbs_prob_ennintegral_def2[OF 1])
qed

lemma(in standard_borel_prob_space) integral_as_qbs_integral:
 "(∫Q x. k x ∂as_qbs_measure) = (∫ x. k x ∂P)"
  by(simp add: as_qbs_measure.abs_eq qbs_prob_integral_def2)

lemma(in standard_borel) measure_with_args_morphism:
  assumes [measurable]:"μ ∈ X →M prob_algebra M"
  shows "standard_borel_prob_space.as_qbs_measure ∘ μ ∈ measure_to_qbs X →Q monadP_qbs (measure_to_qbs M)"
proof(auto intro!: qbs_morphismI)
  fix α
  assume h[measurable]:"α ∈ real_borel →M X"
  have "∀r. (standard_borel_prob_space.as_qbs_measure ∘ μ ∘ α) r = qbs_prob_space (measure_to_qbs M, g, ((λl. distr (μ l) real_borel f) ∘ α) r)"
  proof auto
    fix r
    interpret sp: standard_borel_prob_space "μ (α r)"
      using measurable_space[OF assms measurable_space[OF h]]
      by(simp add: standard_borel_prob_space_def space_prob_algebra)
    have 1[measurable_cong]: "sets (μ (α r)) = sets M"
      using measurable_space[OF assms measurable_space[OF h]] by(simp add: space_prob_algebra)
    have 2:"f ∈ μ (α r) →M real_borel" "g ∈ real_borel →M μ (α r)" "⋀x. x ∈ space (μ (α r)) ⟹ (g ∘ f) x = x"
      using measurable_space[OF assms measurable_space[OF h]]
      by(simp_all add: standard_borel_prob_space_def sets_eq_imp_space_eq[OF 1])
    show "standard_borel_prob_space.as_qbs_measure (μ (α r)) = qbs_prob_space (measure_to_qbs M, g, distr (μ (α r)) real_borel f)"
      by(simp add: sp.as_qbs_measure_retract[OF 2] measure_to_qbs_cong_sets[OF  subprob_measurableD(2)[OF measurable_prob_algebraD[OF assms] measurable_space[OF h]]])
  qed
  thus "standard_borel_prob_space.as_qbs_measure ∘ μ ∘ α ∈ monadP_qbs_MPx (measure_to_qbs M)"
    by(auto intro!: bexI[where x=g] bexI[where x="(λl. distr (μ l) real_borel f) ∘ α"] simp: monadP_qbs_MPx_def in_MPx_def)
qed

lemma(in standard_borel) measure_with_args_recover:
  assumes "μ ∈ space X → space (prob_algebra M)"
      and "x ∈ space X"
    shows "qbs_prob_measure (standard_borel_prob_space.as_qbs_measure (μ x)) = μ x"
    using standard_borel_sets[of "μ x"] funcset_mem[OF assms]
    by(simp add: standard_borel_prob_space_def space_prob_algebra standard_borel_prob_space.measure_as_qbs_measure_recover)

subsection ‹Example of Probability Measures›
text ‹Probability measures on $\mathbb{R}$ can be represented as probability measures on the quasi-Borel space $\mathbb{R}$.›
subsubsection ‹ Normal Distribution ›
definition normal_distribution :: "real × real ⇒ real measure" where
"normal_distribution μσ = (if 0 < (snd μσ) then density lborel (λx. ennreal (normal_density (fst μσ) (snd μσ) x))
                                      else return lborel 0)"

lemma normal_distribution_measurable:
 "normal_distribution ∈ real_borel ⨂M real_borel →M prob_algebra real_borel"
proof(rule measurable_prob_algebra_generated[where Ω=UNIV and G=borel])
  fix A :: "real set"
  assume h:"A ∈ sets borel"
  have "(λx. emeasure (normal_distribution x) A) = (λx. if 0 < (snd x) then emeasure (density lborel (λr. ennreal (normal_density (fst x) (snd x) r))) A
                                                                                     else emeasure (return lborel 0) A)"
    by(auto simp add: normal_distribution_def)
  also have "... ∈ borel_measurable (borel ⨂M borel)"
  proof(rule measurable_If)
    have [simp]:"(λx. indicat_real A (snd x)) ∈ borel_measurable ((borel ⨂M borel) ⨂M borel)"
    proof -
      have "(λx. indicat_real A (snd x)) = indicat_real A ∘ snd"
        by auto
      also have "... ∈ borel_measurable ((borel ⨂M borel) ⨂M borel)"
        by (meson borel_measurable_indicator h measurable_comp measurable_snd)
      finally show ?thesis .
    qed
    have "(λx. emeasure (density lborel (λr. ennreal (normal_density (fst x) (snd x) r))) A) = (λx. set_nn_integral lborel A (λr. ennreal (normal_density (fst x) (snd x) r)))"
      using h by(auto intro!: emeasure_density)
    also have "... = (λx. ∫+r. ennreal (normal_density (fst x) (snd x) r * indicat_real A r)∂lborel)"
      by(simp add: nn_integral_set_ennreal)
    also have "... ∈ borel_measurable (borel ⨂M borel)"
      apply(auto intro!: lborel.borel_measurable_nn_integral
                   simp: split_beta' measurable_cong_sets[OF sets_pair_measure_cong[OF refl sets_lborel]] )
      unfolding normal_density_def
      by(rule borel_measurable_times) simp_all
    finally show "(λx. emeasure (density lborel (λr. ennreal (normal_density (fst x) (snd x) r))) A) ∈ borel_measurable (borel ⨂M borel)" .
  qed simp_all
  finally show "(λx. emeasure (normal_distribution x) A) ∈ borel_measurable (borel ⨂M borel)" .
qed (auto simp add: sets.sigma_sets_eq[of borel,simplified] sets.Int_stable prob_space_normal_density normal_distribution_def prob_space_return)

definition qbs_normal_distribution :: "real ⇒ real ⇒ real qbs_prob_space" where
"qbs_normal_distribution ≡ curry (standard_borel_prob_space.as_qbs_measure ∘ normal_distribution)"

lemma qbs_normal_distribution_morphism:
 "qbs_normal_distribution ∈ ℝQ →Q exp_qbs ℝQ (monadP_qbs ℝQ)"
  unfolding qbs_normal_distribution_def
  by(rule curry_preserves_morphisms[OF real.measure_with_args_morphism[OF normal_distribution_measurable,simplified r_preserves_product]])


context
  fixes μ σ :: real
  assumes sigma:"σ > 0"
begin

interpretation n_dist:standard_borel_prob_space "normal_distribution (μ,σ)"
  by(simp add: standard_borel_prob_space_def sigma prob_space_normal_density normal_distribution_def) 

lemma qbs_normal_distribution_def2:
 "qbs_normal_distribution μ σ = n_dist.as_qbs_measure"
  by(simp add: qbs_normal_distribution_def)

lemma qbs_normal_distribution_integral:
 "(∫Q x. f x ∂ (qbs_normal_distribution μ σ)) = (∫ x. f x ∂ (density lborel (λx. ennreal (normal_density μ σ x))))"
  by(simp add: qbs_normal_distribution_def2 n_dist.integral_as_qbs_integral)
    (simp add: normal_distribution_def sigma)

lemma qbs_normal_distribution_expectation:
  assumes "f ∈ real_borel →M real_borel"
    shows "(∫Q x. f x ∂ (qbs_normal_distribution μ σ)) = (∫ x. normal_density μ σ x * f x ∂ lborel)"
  by(simp add: qbs_normal_distribution_integral assms integral_real_density integral_density)

end

subsubsection ‹ Uniform Distribution ›
definition interval_uniform_distribution :: "real ⇒ real ⇒ real measure" where
"interval_uniform_distribution a b ≡ (if a < b then uniform_measure lborel {a<..<b}
                                               else return lborel 0)"

lemma sets_interval_uniform_distribution[measurable_cong]:
 "sets (interval_uniform_distribution a b) = borel"
  by(simp add: interval_uniform_distribution_def)

lemma interval_uniform_distribution_meaurable:
 "(λr. interval_uniform_distribution (fst r) (snd r)) ∈ real_borel ⨂M real_borel →M prob_algebra real_borel"
proof(rule measurable_prob_algebra_generated[where Ω=UNIV and G="range (λ(a, b). {a<..<b})"])
  show "sets real_borel = sigma_sets UNIV (range (λ(a, b). {a<..<b}))"
    by(simp add: borel_eq_box)
next
  show "Int_stable (range (λ(a, b). {a<..<b::real}))"
    by(fastforce intro!: Int_stableI simp: split_beta' image_iff)
next
  show "range (λ(a, b). {a<..<b}) ⊆ Pow UNIV"
    by simp
next
  fix a
  show "prob_space (interval_uniform_distribution (fst a) (snd a))"
    by(simp add: interval_uniform_distribution_def prob_space_return prob_space_uniform_measure)
next
  fix a
  show " sets (interval_uniform_distribution (fst a) (snd a)) = sets real_borel"
    by(simp add: interval_uniform_distribution_def)
next
  fix A
  assume "A ∈ range (λ(a, b). {a<..<b::real})"
  then obtain a b where ha:"A = {a<..<b}" by auto
  consider  "b ≤ a" | "a < b" by fastforce
  then show "(λx. emeasure (interval_uniform_distribution (fst x) (snd x)) A) ∈ real_borel ⨂M real_borel →M ennreal_borel"
             (is "?f ∈ ?meas")
  proof cases
    case 1
    then show ?thesis
      by(simp add: ha)
  next
    case h2:2
    have "?f = (λx. if fst x < snd x then ennreal (min (snd x) b - max (fst x) a) / ennreal (snd x - fst x) else indicator A 0)"
    proof(standard; auto simp: interval_uniform_distribution_def ha)
      fix x y :: real
      assume hxy:"x < y"
      consider "b ≤ x" | "a ≤ x ∧ x < b" | "x < a ∧ a < y" | "y ≤ a"
        using h2 by fastforce
      thus "emeasure lborel ({max x a<..<min y b}) / ennreal (y - x) = ennreal (min y b - max x a) / ennreal (y - x)"
        by cases (use hxy ennreal_neg h2 in auto)
    qed
    also have "... ∈ ?meas"
      by simp
    finally show ?thesis .
  qed
qed

definition qbs_interval_uniform_distribution :: "real ⇒ real ⇒ real qbs_prob_space" where
"qbs_interval_uniform_distribution ≡ curry (standard_borel_prob_space.as_qbs_measure ∘ (λr. interval_uniform_distribution (fst r) (snd r)))"

lemma qbs_interval_uniform_distribution_morphism:
 "qbs_interval_uniform_distribution ∈ ℝQ →Q exp_qbs ℝQ (monadP_qbs ℝQ)"
  unfolding qbs_interval_uniform_distribution_def
  using curry_preserves_morphisms[OF real.measure_with_args_morphism[OF interval_uniform_distribution_meaurable,simplified r_preserves_product]] .

context
  fixes a b :: real
  assumes a_less_than_b:"a < b"
begin

definition "ab_qbs_uniform_distribution ≡ qbs_interval_uniform_distribution a b"

interpretation ab_u_dist: standard_borel_prob_space "interval_uniform_distribution a b"
  by(auto intro!: prob_space_uniform_measure simp: interval_uniform_distribution_def standard_borel_prob_space_def prob_space_return)

lemma qbs_interval_uniform_distribution_def2:
 "ab_qbs_uniform_distribution = ab_u_dist.as_qbs_measure"
  by(simp add: qbs_interval_uniform_distribution_def ab_qbs_uniform_distribution_def)

lemma qbs_uniform_distribution_expectation:
  assumes "f ∈ ℝQ →Q ℝQ≥0"
  shows "(∫+Q x. f x ∂ab_qbs_uniform_distribution) = (∫+x ∈ {a<..<b}. f x ∂lborel) / (b - a)"
        (is "?lhs = ?rhs")
proof -
  have "?lhs = (∫+x. f x ∂(interval_uniform_distribution a b))"
    using assms by(auto simp: qbs_interval_uniform_distribution_def2 intro!:ab_u_dist.ennintegral_as_qbs_ennintegral dest:ab_u_dist.qbs_morphism_dest[simplified measure_to_qbs_cong_sets[OF sets_interval_uniform_distribution]])
  also have "... = ?rhs"
    using assms
    by(auto simp: interval_uniform_distribution_def a_less_than_b intro!:nn_integral_uniform_measure[where M=lborel and S="{a<..<b}",simplified emeasure_lborel_Ioo[OF order.strict_implies_order[OF a_less_than_b]]])
  finally show ?thesis .
qed

end

subsubsection ‹ Bernoulli Distribution ›
definition qbs_bernoulli :: "real ⇒ bool qbs_prob_space" where
"qbs_bernoulli ≡ standard_borel_prob_space.as_qbs_measure ∘ (λx. measure_pmf (bernoulli_pmf x))"

lemma bernoulli_measurable:
 "(λx. measure_pmf (bernoulli_pmf x)) ∈ real_borel →M prob_algebra bool_borel"
proof(rule measurable_prob_algebra_generated[where Ω=UNIV and G=UNIV],simp_all)
  fix A :: "bool set"
  have "A ⊆ {True,False}"
    by auto
  then consider "A = {}" | "A = {True}" | "A = {False}" | "A = {False,True}"
    by auto
  thus "(λa. emeasure (measure_pmf (bernoulli_pmf a)) A) ∈ borel_measurable borel"
    by(cases,simp_all add: emeasure_measure_pmf_finite bernoulli_pmf.rep_eq UNIV_bool[symmetric])
qed (auto simp add: sets_borel_eq_count_space Int_stable_def measure_pmf.prob_space_axioms)

lemma qbs_bernoulli_morphism:
 "qbs_bernoulli ∈ ℝQ →Q monadP_qbs 𝔹Q"
  using bool.measure_with_args_morphism[OF bernoulli_measurable]
  by (simp add: qbs_bernoulli_def)


lemma qbs_bernoulli_measure:
 "qbs_prob_measure (qbs_bernoulli p) = measure_pmf (bernoulli_pmf p)"
  using bool.measure_with_args_recover[of "λx. measure_pmf (bernoulli_pmf x)" real_borel p] bernoulli_measurable
  by(simp add: measurable_def qbs_bernoulli_def)

context
  fixes p :: real
  assumes pgeq_0[simp]:"0 ≤ p" and pleq_1[simp]:"p ≤ 1"
begin

lemma qbs_bernoulli_expectation:
  "(∫Q x. f x ∂qbs_bernoulli p) = f True * p + f False * (1 - p)"
  by(simp add: qbs_prob_integral_def2 qbs_bernoulli_measure)

end

end

Theory Bayesian_Linear_Regression

(*  Title:   Bayesian_Linear_Regression.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsection ‹ Bayesian Linear Regression ›

theory Bayesian_Linear_Regression
  imports "Measure_as_QuasiBorel_Measure"
begin

text ‹ We formalize the Bayesian linear regression presented in \cite{Heunen_2017} section VI.›
subsubsection ‹ Prior ›
abbreviation "ν ≡ density lborel (λx. ennreal (normal_density 0 3 x))"

interpretation ν: standard_borel_prob_space ν
  by(simp add: standard_borel_prob_space_def prob_space_normal_density)

term "ν.as_qbs_measure :: real qbs_prob_space"
definition prior :: "(real ⇒ real) qbs_prob_space" where
 "prior ≡ do { s ← ν.as_qbs_measure ;
                b ← ν.as_qbs_measure ;
                qbs_return (ℝQ ⇒Q ℝQ) (λr. s * r + b)}"

lemma ν_as_qbs_measure_eq:
 "ν.as_qbs_measure = qbs_prob_space (ℝQ,id,ν)"
  by(simp add: ν.as_qbs_measure_retract[of id id] distr_id' measure_to_qbs_cong_sets[OF sets_density] measure_to_qbs_cong_sets[OF sets_lborel])

interpretation ν_qp: pair_qbs_prob "ℝQ" id ν "ℝQ" id ν
  by(auto intro!: qbs_probI prob_space_normal_density simp: pair_qbs_prob_def)

lemma ν_as_qbs_measure_in_Pr:
 "ν.as_qbs_measure ∈ monadP_qbs_Px ℝQ"
  by(simp add: ν_as_qbs_measure_eq ν_qp.qp1.qbs_prob_space_in_Px)

lemma sets_real_real_real[measurable_cong]:
  "sets (qbs_to_measure ((ℝQ ⨂Q ℝQ) ⨂Q ℝQ)) = sets ((borel ⨂M borel) ⨂M borel)"
  by (metis pair_standard_borel.l_r_r_sets pair_standard_borel_def r_preserves_product real.standard_borel_axioms real_real.standard_borel_axioms)

lemma lin_morphism:
 "(λ(s, b) r. s * r + b) ∈ ℝQ ⨂Q ℝQ →Q ℝQ ⇒Q ℝQ"
  apply(simp add: split_beta')
  apply(rule curry_preserves_morphisms[of "λ(x,r). fst x * r + snd x",simplified curry_def split_beta',simplified])
  by auto

lemma lin_measurable[measurable]:
 "(λ(s, b) r. s * r + b) ∈ real_borel ⨂M real_borel →M qbs_to_measure (ℝQ ⇒Q ℝQ)"
  using lin_morphism l_preserves_morphisms[of "ℝQ ⨂Q ℝQ" "exp_qbs ℝQ ℝQ"]
  by auto

lemma prior_computation:
 "qbs_prob (ℝQ ⇒Q ℝQ) ((λ(s, b) r. s * r + b) ∘ real_real.g) (distr (ν ⨂M ν) real_borel real_real.f)" 
 "prior = qbs_prob_space (ℝQ ⇒Q ℝQ, (λ(s, b) r. s * r + b) ∘ real_real.g, distr (ν ⨂M ν) real_borel real_real.f)"
  using ν_qp.qbs_bind_bind_return[OF lin_morphism]
  by(simp_all add: prior_def ν_as_qbs_measure_eq map_prod_def)

text ‹ The following lemma corresponds to the equation (5). ›
lemma prior_measure:
  "qbs_prob_measure prior = distr (ν ⨂M ν) (qbs_to_measure (exp_qbs ℝQ ℝQ)) (λ(s,b) r. s * r + b)"
  by(simp add: prior_computation(2) qbs_prob.qbs_prob_measure_computation[OF prior_computation(1)])    (simp add: distr_distr comp_def)

lemma prior_in_space:
 "prior ∈ qbs_space (monadP_qbs (ℝQ ⇒Q ℝQ))"
  using qbs_prob.qbs_prob_space_in_Px[OF prior_computation(1)]
  by(simp add: prior_computation(2))


subsubsection ‹ Likelihood ›
abbreviation "d μ x ≡ normal_density μ (1/2) x"

lemma d_positive : "0 < d μ x"
  by(simp add: normal_density_pos)

definition obs :: "(real ⇒ real) ⇒ ennreal" where
"obs f ≡ d (f 1) 2.5 * d (f 2) 3.8 * d (f 3) 4.5 * d (f 4) 6.2 * d (f 5) 8"

lemma obs_morphism:
 "obs ∈ ℝQ ⇒Q ℝQ →Q ℝQ≥0"
proof(rule qbs_morphismI)
  fix α
  assume "α ∈ qbs_Mx (ℝQ ⇒Q ℝQ)"
  then have [measurable]:"(λ(x,y). α x y) ∈ real_borel ⨂M real_borel →M real_borel"
    by(auto simp: exp_qbs_Mx_def)
  show "obs ∘ α ∈ qbs_Mx ℝQ≥0"
    by(auto simp: comp_def obs_def normal_density_def)
qed

lemma obs_measurable[measurable]:
 "obs ∈ qbs_to_measure (exp_qbs ℝQ ℝQ) →M ennreal_borel"
  using obs_morphism by auto


subsubsection ‹ Posterior ›
lemma id_obs_morphism:
 "(λf. (f,obs f)) ∈ ℝQ ⇒Q ℝQ →Q (ℝQ ⇒Q ℝQ) ⨂Q ℝQ≥0"
  by(rule qbs_morphism_tuple[OF qbs_morphism_ident' obs_morphism])

lemma push_forward_measure_in_space:
 "monadP_qbs_Pf (ℝQ ⇒Q ℝQ) ((ℝQ ⇒Q ℝQ) ⨂Q ℝQ≥0) (λf. (f,obs f)) prior ∈ qbs_space (monadP_qbs ((ℝQ ⇒Q ℝQ) ⨂Q ℝQ≥0))"
  by(rule qbs_morphismE(2)[OF monadP_qbs_Pf_morphism[OF id_obs_morphism] prior_in_space])

lemma push_forward_measure_computation:
 "qbs_prob ((ℝQ ⇒Q ℝQ) ⨂Q ℝQ≥0) (λl. (((λ(s, b) r. s * r + b) ∘ real_real.g) l, ((obs ∘ (λ(s, b) r. s * r + b)) ∘ real_real.g) l)) (distr (ν ⨂M ν) real_borel real_real.f)"
 "monadP_qbs_Pf (ℝQ ⇒Q ℝQ) ((ℝQ ⇒Q ℝQ) ⨂Q ℝQ≥0) (λf. (f, obs f)) prior = qbs_prob_space ((ℝQ ⇒Q ℝQ) ⨂Q ℝQ≥0, (λl. (((λ(s, b) r. s * r + b) ∘ real_real.g) l, ((obs ∘ (λ(s, b) r. s * r + b)) ∘ real_real.g) l)), distr (ν ⨂M ν) real_borel real_real.f)"
  using qbs_prob.monadP_qbs_Pf_computation[OF prior_computation id_obs_morphism] by(auto simp: comp_def)

subsubsection ‹ Normalizer ›
text ‹ We use the unit space for an error. ›
definition norm_qbs_measure :: "('a × ennreal) qbs_prob_space ⇒ 'a qbs_prob_space + unit" where
"norm_qbs_measure p ≡ (let (XR,αβ,ν) = rep_qbs_prob_space p in
                          if emeasure (density ν (snd ∘ αβ)) UNIV = 0 then Inr ()
                          else if emeasure (density ν (snd ∘ αβ)) UNIV = ∞ then Inr ()
                          else Inl (qbs_prob_space (map_qbs fst XR, fst ∘ αβ, density ν (λr. snd (αβ r) / emeasure (density ν (snd ∘ αβ)) UNIV))))"


lemma norm_qbs_measure_qbs_prob:
  assumes "qbs_prob (X ⨂Q ℝQ≥0) (λr. (α r, β r)) μ"
          "emeasure (density μ β) UNIV ≠ 0"
      and "emeasure (density μ β) UNIV ≠ ∞"
    shows "qbs_prob X α (density μ (λr. (β r) / emeasure (density μ β) UNIV))"
proof -
  interpret qp: qbs_prob "X ⨂Q ℝQ≥0" "λr. (α r, β r)" μ
    by fact
  have ha[simp]: "α ∈ qbs_Mx X"
   and hb[measurable] :"β ∈ real_borel →M ennreal_borel"
    using assms by(simp_all add: qbs_prob_def in_Mx_def pair_qbs_Mx_def comp_def)
  show ?thesis
  proof(rule qbs_probI)
    show "prob_space (density μ (λr. β r / emeasure (density μ β) UNIV))"
    proof(rule prob_spaceI)
      show "emeasure (density μ (λr. β r / emeasure (density μ β) UNIV)) (space (density μ (λr. β r / emeasure (density μ β) UNIV))) = 1"
             (is "?lhs = ?rhs")
      proof -
        have "?lhs = emeasure (density μ (λr. β r / emeasure (density μ β) UNIV)) UNIV"
          by simp
        also have "... = (∫+r∈UNIV. (β r / emeasure (density μ β) UNIV) ∂μ)"
          by(intro emeasure_density) auto
        also have "... =  integralN μ (λr. β r / emeasure (density μ β) UNIV)"
          by simp
        also have "... = (integralN μ β) / emeasure (density μ β) UNIV"
          by(simp add: nn_integral_divide)
        also have "... = (∫+r∈UNIV. β r ∂μ) / emeasure (density μ β) UNIV"
          by(simp add: emeasure_density)
        also have "... = 1"
          using assms(2,3) by(simp add: emeasure_density divide_eq_1_ennreal)
        finally show ?thesis .
      qed
    qed
  qed simp_all
qed

lemma norm_qbs_measure_computation:
  assumes "qbs_prob (X ⨂Q ℝQ≥0) (λr. (α r, β r)) μ"
  shows "norm_qbs_measure (qbs_prob_space (X ⨂Q ℝQ≥0, (λr. (α r, β r)), μ)) = (if emeasure (density μ β) UNIV = 0 then Inr ()
                                                                                else if emeasure (density μ β) UNIV = ∞ then Inr ()
                                                                                else Inl (qbs_prob_space (X, α, density μ (λr. (β r) / emeasure (density μ β) UNIV))))"
proof -
  interpret qp: qbs_prob "X ⨂Q ℝQ≥0" "λr. (α r, β r)" μ
    by fact
  have ha: "α ∈ qbs_Mx X"
   and hb[measurable] :"β ∈ real_borel →M ennreal_borel"
    using assms by(simp_all add: qbs_prob_def in_Mx_def pair_qbs_Mx_def comp_def)
  show ?thesis
    unfolding norm_qbs_measure_def
  proof(rule qp.in_Rep_induct)
    fix XR αβ' μ'
    assume "(XR,αβ',μ') ∈ Rep_qbs_prob_space (qbs_prob_space (X ⨂Q ℝQ≥0, λr. (α r, β r), μ))"
    from qp.if_in_Rep[OF this]
    have h:"XR = X ⨂Q ℝQ≥0"
           "qbs_prob XR αβ' μ'"
           "qbs_prob_eq (X ⨂Q ℝQ≥0, λr. (α r, β r), μ) (XR, αβ', μ')"
      by auto
    have hint: "⋀f. f ∈ X ⨂Q ℝQ≥0 →Q ℝQ≥0 ⟹ (∫+ x. f (α x, β x) ∂μ) = (∫+ x. f (αβ' x) ∂μ')"
      using h(3)[simplified qbs_prob_eq_equiv14] by(simp add: qbs_prob_eq4_def)
    interpret qp': qbs_prob XR αβ' μ'
      by fact
    have ha': "fst ∘ αβ' ∈ qbs_Mx X" "(λx. fst (αβ' x)) ∈ qbs_Mx X"
     and hb'[measurable]: "snd ∘ αβ' ∈ real_borel →M ennreal_borel" "(λx. snd (αβ' x)) ∈ real_borel →M ennreal_borel" "(λx. fst (αβ' x)) ∈ real_borel →M qbs_to_measure X"
      using h by(simp_all add: qbs_prob_def in_Mx_def pair_qbs_Mx_def comp_def)
    have fstX: "map_qbs fst XR = X"
      by(simp add: h(1) pair_qbs_fst)
    have he:"emeasure (density μ β) UNIV = emeasure (density μ' (snd ∘ αβ')) UNIV"
      using hint[OF snd_qbs_morphism] by(simp add: emeasure_density)

    show "(let a = (XR,αβ',μ') in case a of (XR, αβ, ν') ⇒ if emeasure (density ν' (snd ∘ αβ)) UNIV = 0 then Inr ()
                                                else if emeasure (density ν' (snd ∘ αβ)) UNIV = ∞ then Inr ()
                                                else Inl (qbs_prob_space (map_qbs fst XR, fst ∘ αβ, density ν' (λr. snd (αβ r) / emeasure (density ν' (snd ∘ αβ)) UNIV))))
         = (if emeasure (density μ β) UNIV = 0 then Inr ()
            else if emeasure (density μ β) UNIV = ∞ then Inr ()
            else Inl (qbs_prob_space (X, α, density μ (λr. β r / emeasure (density μ β) UNIV))))"
    proof(auto simp: he[symmetric] fstX)
      assume het0:"emeasure (density μ β) UNIV ≠ ⊤"
                  "emeasure (density μ β) UNIV ≠ 0"
      interpret pqp: pair_qbs_prob X "fst ∘ αβ'" "density μ' (λr. snd (αβ' r) / emeasure (density μ β) UNIV)" X α "density μ (λr. β r / emeasure (density μ β) UNIV)"
        apply(auto intro!: norm_qbs_measure_qbs_prob  simp: pair_qbs_prob_def assms het0)
        using het0
        by(auto intro!: norm_qbs_measure_qbs_prob[of X "fst ∘ αβ'" "snd ∘ αβ'",simplified,OF h(2)[simplified h(1)]] simp: he)

      show "qbs_prob_space (X, fst ∘ αβ', density μ' (λr. snd (αβ' r) / emeasure (density μ β) UNIV)) = qbs_prob_space (X, α, density μ (λr. β r / emeasure (density μ β) UNIV))"
      proof(rule pqp.qbs_prob_space_eq4)
        fix f
        assume hf[measurable]:"f ∈ qbs_to_measure X →M ennreal_borel"
        show "(∫+ x. f ((fst ∘ αβ') x) ∂density μ' (λr. snd (αβ' r) / emeasure (density μ β) UNIV)) = (∫+ x. f (α x) ∂density μ (λr. β r / emeasure (density μ β) UNIV))"
             (is "?lhs = ?rhs")
        proof -
          have "?lhs =  (∫+ x. (λxr. (snd xr) / emeasure (density μ β) UNIV * f (fst xr)) (αβ' x) ∂μ')"
            by(auto simp: nn_integral_density)
          also have "... = (∫+ x. (λxr. (snd xr) / emeasure (density μ β) UNIV * f (fst xr)) (α x,β x) ∂μ)"
            by(intro hint[symmetric]) (auto intro!: pair_qbs_morphismI)
          also have "... = ?rhs"
            by(simp add: nn_integral_density)
          finally show ?thesis .
        qed
      qed simp
    qed
  qed
qed

lemma norm_qbs_measure_morphism:
 "norm_qbs_measure ∈ monadP_qbs (X ⨂Q ℝQ≥0) →Q monadP_qbs X <+>Q 1Q"
proof(rule qbs_morphismI)
  fix γ
  assume "γ ∈ qbs_Mx (monadP_qbs (X ⨂Q ℝQ≥0))"
  then obtain α g where hc:
   "α ∈ qbs_Mx (X ⨂Q ℝQ≥0)" "g ∈ real_borel →M prob_algebra real_borel"
      "γ = (λr. qbs_prob_space (X ⨂Q ℝQ≥0, α, g r))"
    using rep_monadP_qbs_MPx[of "γ" "(X ⨂Q ℝQ≥0)"] by auto
  note [measurable] = hc(2) measurable_prob_algebraD[OF hc(2)]
  have setsg[measurable_cong]:"⋀r. sets (g r) = sets real_borel"
    using measurable_space[OF hc(2)] by(simp add: space_prob_algebra)
  then have ha: "fst ∘ α ∈ qbs_Mx X"
   and hb[measurable]: "snd ∘ α ∈ real_borel →M ennreal_borel" "(λx. snd (α x)) ∈ real_borel →M ennreal_borel" "⋀r. snd ∘ α ∈ g r  →M ennreal_borel" "⋀r. (λx. snd (α x)) ∈ g r  →M ennreal_borel"
    using hc(1) by(auto simp add: pair_qbs_Mx_def measurable_cong_sets[OF setsg refl] comp_def)
  have emeas_den_meas[measurable]: "⋀U. U ∈ sets real_borel ⟹ (λr. emeasure (density (g r) (snd ∘ α)) U) ∈ real_borel →M ennreal_borel"
    by(simp add: emeasure_density)
  have S_setsc:"UNIV - (λr. emeasure (density (g r) (snd ∘ α)) UNIV) -` {0,∞} ∈ sets real_borel"
    using measurable_sets_borel[OF emeas_den_meas] by simp
  have space_non_empty:"qbs_space (monadP_qbs X) ≠ {}"
    using ha qbs_empty_equiv monadP_qbs_empty_iff[of X] by auto
  have g_meas:"(λr. if r ∈ (UNIV - (λr. emeasure (density (g r) (snd ∘ α)) UNIV) -` {0,∞}) then density (g r) (λl. ((snd ∘ α) l) / emeasure (density (g r) (snd ∘ α)) UNIV) else return real_borel 0) ∈ real_borel →M prob_algebra real_borel"
  proof -
    have H:"⋀Ω M N c f. Ω ∩ space M ∈ sets M ⟹ c ∈ space N ⟹
             f ∈ measurable (restrict_space M Ω) N ⟹ (λx. if x ∈ Ω then f x else c) ∈ measurable M N"
      by(simp add: measurable_restrict_space_iff)
    show ?thesis
    proof(rule H)
      show "(UNIV - (λr. emeasure (density (g r) (snd ∘ α)) UNIV) -` {0, ∞}) ∩ space real_borel ∈ sets real_borel"
        using S_setsc by simp
    next
      show "(λr. density (g r) (λl. ((snd ∘ α) l) / emeasure (density (g r) (snd ∘ α)) UNIV)) ∈ restrict_space real_borel (UNIV - (λr. emeasure (density (g r) (snd ∘ α)) UNIV) -` {0,∞}) →M prob_algebra real_borel"
      proof(rule measurable_prob_algebra_generated[where Ω=UNIV and G="sets real_borel"])

        fix a
        assume "a ∈ space (restrict_space real_borel (UNIV - (λr. emeasure (density (g r) (snd ∘ α)) UNIV) -` {0, ∞}))"
        then have 1:"(∫+ x. snd (α x) ∂g a) ≠ 0" "(∫+ x. snd (α x) ∂g a) ≠ ∞"
          by(simp_all add: space_restrict_space emeasure_density)
        show "prob_space (density (g a) (λl. (snd ∘ α) l / emeasure (density (g a) (snd ∘ α)) UNIV))"
          using 1
          by(auto intro!: prob_spaceI simp: emeasure_density nn_integral_divide divide_eq_1_ennreal)
      next
        fix U
        assume 1:"U ∈ sets real_borel"
        then have 2:"⋀a. U ∈ sets (g a)" by auto
        show "(λa. emeasure (density (g a) (λl. (snd ∘ α) l / emeasure (density (g a) (snd ∘ α)) UNIV)) U) ∈ (restrict_space real_borel (UNIV - (λr. emeasure (density (g r) (snd ∘ α)) UNIV) -` {0, ∞})) →M ennreal_borel"
          using 1
          by(auto intro!: measurable_restrict_space1 nn_integral_measurable_subprob_algebra2[where N=real_borel] simp: emeasure_density emeasure_density[OF _ 2])
      qed (simp_all add: setsg sets.Int_stable sets.sigma_sets_eq[of real_borel,simplified])
    qed (simp add:space_prob_algebra prob_space_return)
  qed

  show "norm_qbs_measure ∘ γ ∈ qbs_Mx (monadP_qbs X <+>Q unit_quasi_borel)"
    apply(auto intro!: bexI[OF _ S_setsc] bexI[where x="(λr. ())"] bexI[where x="λr. qbs_prob_space (X,fst ∘ α,if r ∈ (UNIV - (λr. emeasure (density (g r) (snd ∘ α)) UNIV) -` {0,∞}) then density (g r) (λl. ((snd ∘ α) l) / emeasure (density (g r) (snd ∘ α)) UNIV) else return real_borel 0)"]
                 simp: copair_qbs_Mx_equiv copair_qbs_Mx2_def space_non_empty[simplified])
     apply standard
     apply(simp add: hc(3) norm_qbs_measure_computation[of _ "fst ∘ α" "snd ∘ α",simplified,OF qbs_prob_MPx[OF hc(1,2)]])
    apply(simp add: monadP_qbs_MPx_def in_MPx_def)
    apply(auto intro!: bexI[OF _ ha] bexI[OF _ g_meas])
    done
qed


text ‹ The following is the semantics of the entire program. ›
definition program :: "(real ⇒ real) qbs_prob_space + unit" where
 "program ≡ norm_qbs_measure (monadP_qbs_Pf (ℝQ ⇒Q ℝQ) ((ℝQ ⇒Q ℝQ) ⨂Q ℝQ≥0) (λf. (f,obs f)) prior)"

lemma program_in_space:
 "program ∈ qbs_space (monadP_qbs (ℝQ ⇒Q ℝQ) <+>Q 1Q)"
  unfolding program_def
  by(rule qbs_morphismE(2)[OF norm_qbs_measure_morphism push_forward_measure_in_space])


text ‹ We calculate the normalizing constant. ›
lemma complete_the_square:
  fixes a b c x :: real
  assumes "a ≠ 0"
  shows "a*x2 + b * x + c = a * (x + (b / (2*a)))2 - ((b2 - 4* a * c)/(4*a))"
  using assms by(simp add: comm_semiring_1_class.power2_sum power2_eq_square[of "b / (2 * a)"] ring_class.ring_distribs(1) division_ring_class.diff_divide_distrib power2_eq_square[of b])

lemma complete_the_square2':
  fixes a b c x :: real
  assumes "a ≠ 0"
  shows "a*x2 - 2 * b * x + c = a * (x - (b / a))2 - ((b2 - a*c)/a)"
  using complete_the_square[OF assms,where b="-2 * b" and x=x and c=c]
  by(simp add: division_ring_class.diff_divide_distrib assms)


lemma normal_density_mu_x_swap:
   "normal_density μ σ x = normal_density x σ μ"
  by(simp add: normal_density_def power2_commute)

lemma normal_density_plus_shift:
 "normal_density μ σ (x + y) = normal_density (μ - x) σ y"
  by(simp add: normal_density_def add.commute diff_diff_eq2)

lemma normal_density_times:
  assumes "σ > 0" "σ' > 0"
  shows "normal_density μ σ x * normal_density μ' σ' x = (1 / sqrt (2 * pi * (σ2 + σ'2))) * exp (- (μ - μ')2 / (2 * (σ2 + σ'2))) * normal_density ((μ*σ'2 + μ'*σ2)/(σ2 + σ'2)) (σ * σ' / sqrt (σ2 + σ'2)) x"
        (is "?lhs = ?rhs")
proof -
  have non0: "2*σ2 ≠ 0" "2*σ'2 ≠ 0" "σ2 + σ'2 ≠ 0"
    using assms by auto
  have "?lhs = exp (- ((x - μ)2 / (2 * σ2))) * exp (- ((x - μ')2 / (2 * σ'2))) / (sqrt (2 * pi * σ2) * sqrt (2 * pi * σ'2)) "
    by(simp add: normal_density_def)
  also have "... = exp (- ((x - μ)2 / (2 * σ2)) - ((x - μ')2 / (2 * σ'2))) / (sqrt (2 * pi * σ2) * sqrt (2 * pi * σ'2))"
    by(simp add: exp_add[of "- ((x - μ)2 / (2 * σ2))" "- ((x - μ')2 / (2 * σ'2))",simplified add_uminus_conv_diff])
  also have "... = exp (- (x - (μ * σ'2 + μ' * σ2) / (σ2 + σ'2))2 / (2 * (σ * σ' / sqrt (σ2 + σ'2))2) - (μ - μ')2 / (2 * (σ2 + σ'2)))  / (sqrt (2 * pi * σ2) * sqrt (2 * pi * σ'2))"
  proof -
    have "((x - μ)2 / (2 * σ2)) + ((x - μ')2 / (2 * σ'2)) = (x - (μ * σ'2 + μ' * σ2) / (σ2 + σ'2))2 / (2 * (σ * σ' / sqrt (σ2 + σ'2))2) + (μ - μ')2 / (2 * (σ2 + σ'2))"
         (is "?lhs' = ?rhs'")
    proof -
      have "?lhs' = (2 * ((x - μ)2 * σ'2) + 2 * ((x - μ')2 * σ2)) / (4 * (σ2 * σ'2))"
        by(simp add: field_class.add_frac_eq[OF non0(1,2)])
      also have "... = ((x - μ)2 * σ'2 + (x - μ')2 * σ2) / (2 * (σ2 * σ'2))"
        by(simp add: power2_eq_square division_ring_class.add_divide_distrib)
      also have "... = ((σ2 + σ'2) * x2 - 2 * (μ * σ'2 + μ' * σ2) * x  + (μ'2 * σ2 + μ2 * σ'2)) / (2 * (σ2 * σ'2))"
        by(simp add: comm_ring_1_class.power2_diff ring_class.left_diff_distrib semiring_class.distrib_right)
       also have "... = ((σ2 + σ'2) * (x - (μ * σ'2 + μ' * σ2) / (σ2 + σ'2))2 - ((μ * σ'2 + μ' * σ2)2 - (σ2 + σ'2) * (μ'2 * σ2 + μ2 * σ'2)) / (σ2 + σ'2)) / (2 * (σ2 * σ'2))"
        by(simp only: complete_the_square2'[OF non0(3),of x "(μ * σ'2 + μ' * σ2)" "(μ'2 * σ2 + μ2 * σ'2)"])
      also have "... = ((σ2 + σ'2) * (x - (μ * σ'2 + μ' * σ2) / (σ2 + σ'2))2) / (2 * (σ2 * σ'2)) - (((μ * σ'2 + μ' * σ2)2 - (σ2 + σ'2) * (μ'2 * σ2 + μ2 * σ'2)) / (σ2 + σ'2)) / (2 * (σ2 * σ'2))"
        by(simp add: division_ring_class.diff_divide_distrib)
      also have "... = (x - (μ * σ'2 + μ' * σ2) / (σ2 + σ'2))2 / (2 * ((σ * σ') / sqrt (σ2 + σ'2))2) - (((μ * σ'2 + μ' * σ2)2 - (σ2 + σ'2) * (μ'2 * σ2 + μ2 * σ'2)) / (σ2 + σ'2)) / (2 * (σ2 * σ'2))"
        by(simp add: monoid_mult_class.power2_eq_square[of "(σ * σ') / sqrt (σ2 + σ'2)"] ab_semigroup_mult_class.mult.commute[of "σ2 + σ'2"] )
          (simp add: monoid_mult_class.power2_eq_square[of σ] monoid_mult_class.power2_eq_square[of σ'])
      also have "... =  (x - (μ * σ'2 + μ' * σ2) / (σ2 + σ'2))2 / (2 * (σ * σ' / sqrt (σ2 + σ'2))2) - ((μ * σ'2)2 + (μ' * σ2)2 + 2 * (μ * σ'2) * (μ' * σ2) - (σ2 * (μ'2 * σ2) + σ2 * (μ2 * σ'2) + (σ'2 * (μ'2 * σ2) + σ'2 * (μ2 * σ'2)))) / ((σ2 + σ'2) * (2 * (σ2 * σ'2)))"
        by(simp add: comm_semiring_1_class.power2_sum[of "μ * σ'2" "μ' * σ2"] semiring_class.distrib_right[of "σ2" "σ'2" "μ'2 * σ2 + μ2 * σ'2"] )
          (simp add: semiring_class.distrib_left[of _ "μ'2 * σ2 " "μ2 * σ'2"])
      also have "... = (x - (μ * σ'2 + μ' * σ2) / (σ2 + σ'2))2 / (2 * (σ * σ' / sqrt (σ2 + σ'2))2) + ((σ2 * σ'2)*μ2 + (σ2 * σ'2)*μ'2 - (σ2 * σ'2) * 2 * (μ*μ')) / ((σ2 + σ'2) * (2 * (σ2 * σ'2)))"
        by(simp add: monoid_mult_class.power2_eq_square division_ring_class.minus_divide_left)
      also have "... = (x - (μ * σ'2 + μ' * σ2) / (σ2 + σ'2))2 / (2 * (σ * σ' / sqrt (σ2 + σ'2))2) + (μ2 + μ'2 - 2 * (μ*μ')) / ((σ2 + σ'2) * 2)"
        using assms by(simp add: division_ring_class.add_divide_distrib division_ring_class.diff_divide_distrib)
      also have "... = ?rhs'"
        by(simp add: comm_ring_1_class.power2_diff ab_semigroup_mult_class.mult.commute[of 2])
      finally show ?thesis .
    qed
    thus ?thesis
      by simp
  qed
  also have "... = (exp (- (μ - μ')2 / (2 * (σ2 + σ'2))) / (sqrt (2 * pi * σ2) * sqrt (2 * pi * σ'2))) * sqrt (2 * pi * (σ * σ' / sqrt (σ2 + σ'2))2)  * normal_density ((μ * σ'2 + μ' * σ2) / (σ2 + σ'2)) (σ * σ' / sqrt (σ2 + σ'2)) x"
    by(simp add: exp_add[of "- (x - (μ * σ'2 + μ' * σ2) / (σ2 + σ'2))2 / (2 * (σ * σ' / sqrt (σ2 + σ'2))2)" "- (μ - μ')2 / (2 * (σ2 + σ'2))",simplified] normal_density_def)
  also have "... = ?rhs" 
  proof -
    have "exp (- (μ - μ')2 / (2 * (σ2 + σ'2))) / (sqrt (2 * pi * σ2) * sqrt (2 * pi * σ'2)) * sqrt (2 * pi * (σ * σ' / sqrt (σ2 + σ'2))2) = 1 / sqrt (2 * pi * (σ2 + σ'2)) * exp (- (μ - μ')2 / (2 * (σ2 + σ'2)))"
      using assms by(simp add: real_sqrt_mult)
    thus ?thesis
      by simp
  qed
  finally show ?thesis .
qed

lemma normal_density_times':
  assumes "σ > 0" "σ' > 0"
  shows "a * normal_density μ σ x * normal_density μ' σ' x = a * (1 / sqrt (2 * pi * (σ2 + σ'2))) * exp (- (μ - μ')2 / (2 * (σ2 + σ'2))) * normal_density ((μ*σ'2 + μ'*σ2)/(σ2 + σ'2)) (σ * σ' / sqrt (σ2 + σ'2)) x"
  using normal_density_times[OF assms,of μ x μ']
  by (simp add: mult.assoc)

lemma normal_density_times_minusx:
  assumes "σ > 0" "σ' > 0" "a ≠ a'"
  shows "normal_density (μ - a*x) σ y * normal_density (μ' - a'*x) σ' y = (1 / ¦a' - a¦) * normal_density ((μ'- μ)/(a'-a)) (sqrt ((σ2 + σ'2)/(a' - a)2)) x * normal_density (((μ - a*x)*σ'2 + (μ' - a'*x)*σ2)/(σ2 + σ'2)) (σ * σ' / sqrt (σ2 + σ'2)) y"
proof -
  have non0:"a' - a ≠ 0"
    using assms(3) by simp
  have "1 / sqrt (2 * pi * (σ2 + σ'2)) * exp (- (μ - a * x - (μ' - a' * x))2 / (2 * (σ2 + σ'2))) = 1 / ¦a' - a¦ * normal_density ((μ' - μ) / (a' - a)) (sqrt ((σ2 + σ'2) / (a' - a)2)) x"
       (is "?lhs = ?rhs")
  proof -
    have "?lhs = 1 / sqrt (2 * pi * (σ2 + σ'2)) * exp (- ((a' - a) * x - (μ' - μ))2 / (2 * (σ2 + σ'2)))"
      by(simp add: ring_class.left_diff_distrib group_add_class.diff_diff_eq2 add.commute add_diff_eq)
    also have "... = 1 / sqrt (2 * pi * (σ2 + σ'2)) * exp (- ((a' - a)2 * (x - (μ' - μ)/(a' - a))2) / (2 * (σ2 + σ'2)))"
    proof -
      have "((a' - a) * x - (μ' - μ))2 = ((a' - a) * (x - (μ' - μ)/(a' - a)))2"
        using non0 by(simp add: ring_class.right_diff_distrib[of "a'-a" x])
      also have "... = (a' - a)2 * (x - (μ' - μ)/(a' - a))2"
        by(simp add: monoid_mult_class.power2_eq_square)
      finally show ?thesis
        by simp
    qed
    also have "... = 1 / sqrt (2 * pi * (σ2 + σ'2)) * sqrt (2 * pi * (sqrt ((σ2 + σ'2)/(a' - a)2))2) * normal_density ((μ' - μ) / (a' - a)) (sqrt ((σ2 + σ'2) / (a' - a)2)) x"
      using non0 by (simp add: normal_density_def)
    also have "... = ?rhs"
    proof -
      have "1 / sqrt (2 * pi * (σ2 + σ'2)) * sqrt (2 * pi * (sqrt ((σ2 + σ'2)/(a' - a)2))2) = 1 / ¦a' - a¦"
        using assms by(simp add: real_sqrt_divide[symmetric]) (simp add: real_sqrt_divide)
      thus ?thesis
        by simp
    qed
    finally show ?thesis .
  qed
  thus ?thesis
    by(simp add:normal_density_times[OF assms(1,2),of "μ - a*x" y "μ' - a'*x"])
qed

text ‹ The following is the normalizing constant of the program. ›
abbreviation "C ≡ ennreal ((4 * sqrt 2 / (pi2 * sqrt (66961 * pi))) * (exp (- (1674761 / 1674025))))"

lemma program_normalizing_constant:
 "emeasure (density (distr (ν ⨂M ν) real_borel real_real.f) (obs ∘ (λ(s, b) r. s * r + b) ∘ real_real.g)) UNIV = C"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = (∫+ x. (obs ∘ (λ(s, b) r. s * r + b) ∘ real_real.g) x ∂ (distr (ν ⨂M ν) real_borel real_real.f))"
    by(simp add: emeasure_density)
  also have "... = (∫+ z. (obs ∘ (λ(s, b) r. s * r + b)) z ∂(ν ⨂M ν))"
    using nn_integral_distr[of real_real.f "ν ⨂M ν" real_borel "obs ∘ (λ(s, b) r. s * r + b) ∘ real_real.g",simplified]
    by(simp add: comp_def)
  also have "... = (∫+ x. ∫+ y. (obs ∘ (λ(s, b) r. s * r + b)) (x, y) ∂ν ∂ν)"
    by(simp only: ν_qp.nn_integral_snd[where f="(obs ∘ (λ(s, b) r. s * r + b))",simplified,symmetric])
      (simp add: ν_qp.Fubini[where f="(obs ∘ (λ(s, b) r. s * r + b))",simplified])
  also have "... = (∫+ x. 2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x ∂ν)"
  proof(rule nn_integral_cong[where M=ν,simplified])
    fix x
    have [measurable]: "(λy. obs (λr. x * r + y)) ∈ real_borel →M ennreal_borel"
      using measurable_Pair2[of "obs ∘ (λ(s, b) r. s * r + b)"] by auto
    show "(∫+ y. (obs ∘ (λ(s, b) r. s * r + b)) (x, y) ∂ν) = 2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x"
          (is "?lhs' = ?rhs'")
    proof -
      have "?lhs' = (∫+ y. ennreal (d (5 / 2 - x) y * d (19 / 5 - x * 2) y * d (9 / 2 - x * 3) y * d (31 / 5 - x * 4) y * d (8 - x * 5) y * normal_density 0 3 y) ∂lborel)"
        by(simp add: nn_integral_density obs_def normal_density_mu_x_swap[where x="5/2"] normal_density_mu_x_swap[where x="19/5"] normal_density_mu_x_swap[where x="9/2"] normal_density_mu_x_swap[where x="31/5"] normal_density_mu_x_swap[where x="8"] normal_density_plus_shift ab_semigroup_mult_class.mult.commute[of "ennreal (normal_density 0 3 _)"] ennreal_mult'[symmetric])
      also have "... = (∫+ y. ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y) ∂lborel)"
      proof(rule nn_integral_cong[where M=lborel,simplified])
        fix y
        have "d (5 / 2 - x) y * d (19 / 5 - x * 2) y * d (9 / 2 - x * 3) y * d (31 / 5 - x * 4) y * d (8 - x * 5) y * normal_density 0 3 y = 2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y"
             (is "?lhs'' = ?rhs''")
        proof -
          have "?lhs'' = normal_density (13 / 10) (1 / sqrt 2) x * normal_density (63 / 20 - (3 / 2) * x)  (sqrt 2 / 4) y * d (9 / 2 - x * 3) y * d (31 / 5 - x * 4) y * d (8 - x * 5) y * normal_density 0 3 y"
          proof -
            have "d (5 / 2 - x) y * d (19 / 5 - x * 2) y = normal_density (13 / 10) (1 / sqrt 2) x * normal_density (63 / 20 - (3 / 2) * x) (sqrt 2 / 4) y"
              by(simp add: normal_density_times_minusx[of "1/2" "1/2" 1 2 "5/2" x y "19/5",simplified ab_semigroup_mult_class.mult.commute[of 2 x],simplified])
                (simp add: monoid_mult_class.power2_eq_square real_sqrt_divide division_ring_class.diff_divide_distrib)
            thus ?thesis
              by simp
          qed
          also have "... = normal_density (13 / 10) (1 / sqrt 2) x * (2 / 3) * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (18 / 5 - 2 * x) (1 / (2 * sqrt 3)) y * d (31 / 5 - x * 4) y * d (8 - x * 5) y * normal_density 0 3 y"
          proof -
            have 1:"sqrt 2 * sqrt 8 / (8 * sqrt 3) = 1 / (2 * sqrt 3)"
              by(simp add: real_sqrt_divide[symmetric] real_sqrt_mult[symmetric])
            have "normal_density (63 / 20 - 3 / 2 * x) (sqrt 2 / 4) y * d (9 / 2 - x * 3) y = (2 / 3) * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (18 / 5 - 2 * x) (1 / (2 * sqrt 3)) y"
              by(simp add: normal_density_times_minusx[of "sqrt 2 / 4" "1 / 2" "3 / 2" 3 "63 / 20" x y "9 / 2",simplified ab_semigroup_mult_class.mult.commute[of 3 x],simplified])
                (simp add: monoid_mult_class.power2_eq_square real_sqrt_divide division_ring_class.diff_divide_distrib 1)
            thus ?thesis
              by simp
          qed
          also have "... = normal_density (13 / 10) (1 / sqrt 2) x * (2 / 3) * normal_density (9 / 10) (1 / sqrt 6) x * (1 / 2) * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (17 / 4 - (5 / 2) * x) (1 / 4) y * d (8 - x * 5) y * normal_density 0 3 y"
          proof -
            have 1:"normal_density (18 / 5 - 2 * x) (1 / (2 * sqrt 3)) y * d (31 / 5 - x * 4) y = (1 / 2) * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (17 / 4 - 5 / 2 * x) (1 / 4) y"
              by(simp add: normal_density_times_minusx[of "1 / (2 * sqrt 3)" "1 / 2" 2 4 "18 / 5" x y "31 / 5",simplified ab_semigroup_mult_class.mult.commute[of 4 x],simplified])
                (simp add: monoid_mult_class.power2_eq_square real_sqrt_divide division_ring_class.diff_divide_distrib)
            show ?thesis
              by(simp add: 1 mult.assoc)
          qed
          also have "... = normal_density (13 / 10) (1 / sqrt 2) x * (2 / 3) * normal_density (9 / 10) (1 / sqrt 6) x * (1 / 2) * normal_density (13 / 10) (1 / sqrt 12) x * (2 / 5) * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 - 3 * x) (1 / (2 * sqrt 5)) y * normal_density 0 3 y"
          proof -
            have 1:"normal_density (17 / 4 - 5 / 2 * x) (1 / 4) y * d (8 - x * 5) y = (2 / 5) * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 - 3 * x) (1 / (2 * sqrt 5)) y"
              by(simp add: normal_density_times_minusx[of "1 / 4" "1 / 2" "5 / 2" 5 "17 / 4" x y 8,simplified ab_semigroup_mult_class.mult.commute[of 5 x],simplified])
                (simp add: monoid_mult_class.power2_eq_square real_sqrt_divide division_ring_class.diff_divide_distrib)
            show ?thesis
              by(simp only: 1 mult.assoc)
          qed
          also have "... = normal_density (13 / 10) (1 / sqrt 2) x * (2 / 3) * normal_density (9 / 10) (1 / sqrt 6) x * (1 / 2) * normal_density (13 / 10) (1 / sqrt 12) x * (2 / 5) * normal_density (3 / 2) (1 / sqrt 20) x * (1 / 3) * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density (20 / 181 * 9 * (5 - 3 * x)) ((3 / (2 * sqrt 5))/ sqrt (181 / 20)) y"
          proof -
            have "normal_density (5 - 3 * x) (1 / (2 * sqrt 5)) y * normal_density 0 3 y = (1 / 3) * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density (20 / 181 * 9 * (5 - 3 * x)) ((3 / (2 * sqrt 5))/ sqrt (181 / 20)) y"
              by(simp add: normal_density_times_minusx[of "1 / (2 * sqrt 5)" 3 3 0 5 x y 0,simplified] monoid_mult_class.power2_eq_square)
            thus ?thesis
              by(simp only: mult.assoc)
          qed
          also have "... = ?rhs''"
            by simp
          finally show ?thesis .
        qed
        thus "ennreal( d (5 / 2 - x) y * d (19 / 5 - x * 2) y * d (9 / 2 - x * 3) y * d (31 / 5 - x * 4) y * d (8 - x * 5) y * normal_density 0 3 y) = ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y )"
          by simp
      qed
      also have "... = (∫+ y. ennreal (normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y) * ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x) ∂lborel)"
        by(simp add: ab_semigroup_mult_class.mult.commute ennreal_mult'[symmetric])
      also have "... = (∫+ y. ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x) ∂ (density lborel (λy. ennreal (normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y))))"
        by(simp add: nn_integral_density[of "λy. ennreal (normal_density (20 / 181 * 9 * (5 - 3 * x)) (3 / (2 * sqrt 5) / sqrt (181 / 20)) y)" lborel,simplified,symmetric])
      also have "... = ?rhs'"
        by(simp add: prob_space.emeasure_space_1[OF prob_space_normal_density[of "3 / (2 * sqrt 5 * sqrt (181 / 20))" "20 / 181 * 9 * (5 - 3 * x)"],simplified])
      finally show ?thesis .
    qed
  qed
  also have "... = (∫+ x. ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x) ∂lborel)"
    by(simp add: nn_integral_density ab_semigroup_mult_class.mult.commute ennreal_mult'[symmetric])
  also have "... = (∫+ x. (4 * sqrt 2 / (pi2 * sqrt (66961 * pi))) * exp (- (1674761 / 1674025)) * normal_density (450072 / 334805) (3 * sqrt 181 / sqrt 66961) x ∂lborel)"
  proof(rule nn_integral_cong[where M=lborel,simplified])
    fix x
    show "ennreal (2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x) = ennreal ((4 * sqrt 2 / (pi2 * sqrt (66961 * pi))) * exp (- (1674761 / 1674025)) * normal_density (450072 / 334805) (3 * sqrt 181 / sqrt 66961) x)"
    proof -
      have "2 / 45 * normal_density (13 / 10) (1 / sqrt 2) x * normal_density (9 / 10) (1 / sqrt 6) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x = (4 * sqrt 2 / (pi2 * sqrt (66961 * pi))) * exp (- (1674761 / 1674025)) * normal_density (450072 / 334805) (3 * sqrt 181 / sqrt 66961) x"
           (is "?lhs' = ?rhs'")
      proof -
        have "?lhs' = 2 / 45 * exp (- (3 / 25)) / sqrt (4 * pi / 3) * normal_density 1 (1 / sqrt 8) x * normal_density (13 / 10) (1 / sqrt 12) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x"
          by(simp add: normal_density_times' monoid_mult_class.power2_eq_square real_sqrt_mult[symmetric])
        also have "... = (2 / (15 * pi * sqrt 5)) * exp (- (42 / 125)) * normal_density (59 / 50) (1 / sqrt 20) x * normal_density (3 / 2) (1 / sqrt 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x"
        proof -
          have 1:"sqrt 8 * sqrt 12 * sqrt (5 / 24) = sqrt 20"
            by(simp add:real_sqrt_mult[symmetric])
          have 2:"sqrt (5 * pi / 12) * (45 * sqrt (4 * pi / 3)) = 15 * (pi * sqrt 5)"
            by(simp add: real_sqrt_mult[symmetric] real_sqrt_divide) (simp add: real_sqrt_mult real_sqrt_mult[of 4 5,simplified])
          have "2 / 45 * exp (- (3 / 25)) / sqrt (4 * pi / 3) * normal_density 1 (1 / sqrt 8) x * normal_density (13 / 10) (1 / sqrt 12) x = (6 / (45 * pi * sqrt 5)) * exp (- (42 / 125)) * normal_density (59 / 50) (1 / sqrt 20) x"
            by(simp add: normal_density_times' monoid_mult_class.power2_eq_square mult_exp_exp[of "- (3 / 25)" "- (27 / 125)",simplified,symmetric] 1 2)
          thus ?thesis
            by simp
        qed
        also have "... = 2 / (15 * pi * sqrt pi) * exp (- (106 / 125)) * normal_density (67 / 50) (sqrt 10 / 20 ) x * normal_density (5 / 3) (sqrt (181 / 180)) x * normal_density 0 3 x"
        proof -
          have "2 / (15 * pi * sqrt 5) * exp (- (42 / 125)) * normal_density (59 / 50) (1 / sqrt 20) x * normal_density (3 / 2) (1 / sqrt 20) x = 2 / (15 * pi * sqrt pi) * exp (- (106 / 125)) * normal_density (67 / 50) (sqrt 10 /20) x"
            by(simp add: normal_density_times' monoid_mult_class.power2_eq_square mult_exp_exp[of "- (42 / 125)" "- (64 / 125)",simplified,symmetric] real_sqrt_divide)
              (simp add: mult.commute)
          thus ?thesis
            by simp
        qed
        also have "... = ((4 * sqrt 5) / (5 * pi2 * sqrt 371)) * exp (- (5961 / 6625)) * normal_density (1786 / 1325) (sqrt 905 / (10 * sqrt 371)) x * normal_density 0 3 x"
        proof -
          have 1:"sqrt (371 * pi / 180) * (15 * pi * sqrt pi) = 5 * pi * pi * sqrt 371 / (2 * sqrt 5)"
            by(simp add: real_sqrt_mult real_sqrt_divide real_sqrt_mult[of 36 5,simplified])
          have 22:"10 = sqrt 5 * 2 * sqrt 5" by simp
          have 2:"sqrt 10 * sqrt (181 / 180) / (20 * sqrt (371 / 360)) = sqrt 905 / (10 * sqrt 371)"
            by(simp add: real_sqrt_mult real_sqrt_divide real_sqrt_mult[of 36 5,simplified] real_sqrt_mult[of 36 10,simplified]  real_sqrt_mult[of 181 5,simplified])
              (simp add: mult.assoc[symmetric] 22)
          have "2 / (15 * pi * sqrt pi) * exp (- (106 / 125)) * normal_density (67 / 50) (sqrt 10 / 20) x * normal_density (5 / 3) (sqrt (181 / 180)) x  = 4 * sqrt 5 / (5 * pi2 * sqrt 371) * exp (- (5961 / 6625)) * normal_density (1786 / 1325) (sqrt 905 / (10 * sqrt 371)) x"
            by(simp add: normal_density_times' monoid_mult_class.power2_eq_square mult_exp_exp[of "- (106 / 125)" "- (343 / 6625)",simplified,symmetric] 1 2)
              (simp add: mult.assoc)
          thus ?thesis
            by simp
        qed
        also have "... = ?rhs'"
        proof -
          have 1: "4 * sqrt 5 / (sqrt (66961 * pi / 3710) * (5 * (pi * pi) * sqrt 371)) = 4 * sqrt 2 / (pi2 * sqrt (66961 * pi))"
            by(simp add: real_sqrt_mult[of 10 371,simplified] real_sqrt_mult[of 5 2,simplified] real_sqrt_divide monoid_mult_class.power2_eq_square mult.assoc)
              (simp add: mult.assoc[symmetric])
          have 2: "sqrt 905 * 3 / (10 * sqrt 371 * sqrt (66961 / 7420)) = 3 * sqrt 181 / sqrt 66961"
            by(simp add: real_sqrt_mult[of 371 20,simplified] real_sqrt_divide real_sqrt_mult[of 4 5,simplified] real_sqrt_mult[of 181 5,simplified]  mult.commute[of _ 3])
              (simp add: mult.assoc)
          show ?thesis
            by(simp only: 1[symmetric]) (simp add: normal_density_times' monoid_mult_class.power2_eq_square mult_exp_exp[of "- (5961 / 6625)" "- (44657144 / 443616625)",simplified,symmetric] 2)
        qed
        finally show ?thesis .
      qed
      thus ?thesis
        by simp
    qed
  qed
  also have "... = (∫+ x. ennreal (normal_density (450072 / 334805) (3 * sqrt 181 / sqrt 66961) x) *  (ennreal (4 * sqrt 2 / (pi2 * sqrt (66961 * pi))) * exp (- (1674761 / 1674025))) ∂lborel)"
    by(simp add: ab_semigroup_mult_class.mult.commute ennreal_mult'[symmetric])
  also have "... = (∫+ x. (ennreal (4 * sqrt 2 / (pi2 * sqrt (66961 * pi))) * exp (- (1674761 / 1674025))) ∂(density lborel (λx. ennreal (normal_density (450072 / 334805) (3 * sqrt 181 / sqrt 66961) x))))"
    by(simp add: nn_integral_density[symmetric])
  also have "... = ?rhs"
    by(simp add: prob_space.emeasure_space_1[OF prob_space_normal_density,simplified] ennreal_mult'[symmetric])
  finally show ?thesis .
qed

text ‹ The program returns a probability measure, rather than error. ›
lemma program_result:
 "qbs_prob (ℝQ ⇒Q ℝQ) ((λ(s, b) r. s * r + b) ∘ real_real.g) (density (distr (ν ⨂M ν) real_borel real_real.f) (λr. (obs ∘ (λ(s, b) r. s * r + b) ∘ real_real.g) r / C))"
 "program = Inl (qbs_prob_space (ℝQ ⇒Q ℝQ, (λ(s, b) r. s * r + b) ∘ real_real.g, density (distr (ν ⨂M ν) real_borel real_real.f) (λr. (obs ∘ (λ(s, b) r. s * r + b) ∘ real_real.g) r / C)))"
  using norm_qbs_measure_computation[OF push_forward_measure_computation(1),simplified program_normalizing_constant]
        norm_qbs_measure_qbs_prob[OF push_forward_measure_computation(1),simplified program_normalizing_constant]
  by(simp_all add: push_forward_measure_computation program_def comp_def)

lemma program_inl:
 "program ∈ Inl ` (qbs_space (monadP_qbs (ℝQ ⇒Q ℝQ)))"
  using program_in_space[simplified program_result(2)]
  by(auto simp: image_def program_result(2))

lemma program_result_measure:
 "qbs_prob_measure (qbs_prob_space (ℝQ ⇒Q ℝQ, (λ(s, b) r. s * r + b) ∘ real_real.g, density (distr (ν ⨂M ν) real_borel real_real.f) (λr. (obs ∘ (λ(s, b) r. s * r + b) ∘ real_real.g) r / C)))
   = density (qbs_prob_measure prior) (λk. obs k / C)"
 (is "?lhs = ?rhs")
proof -
  interpret qp: qbs_prob "exp_qbs ℝQ ℝQ" "(λ(s, b) r. s * r + b) ∘ real_real.g" "density (distr (ν ⨂M ν) real_borel real_real.f) (λr. (obs ∘ (λ(s, b) r. s * r + b) ∘ real_real.g) r / C)"
    by(rule  program_result(1))
  have "?lhs = distr (density (distr (ν ⨂M ν) real_borel real_real.f) (λr. obs (((λ(s, b) r. s * r + b) ∘ real_real.g) r) / C)) (qbs_to_measure (exp_qbs ℝQ ℝQ)) ((λ(s, b) r. s * r + b) ∘ real_real.g)"
    using qp.qbs_prob_measure_computation by simp
  also have "... = density (distr (distr (ν ⨂M ν) real_borel real_real.f) (qbs_to_measure (exp_qbs ℝQ ℝQ)) ((λ(s, b) r. s * r + b) ∘ real_real.g)) (λk. obs k / C)"
    by(simp add: density_distr)
  also have "... = ?rhs"
    by(simp add: distr_distr comp_def prior_measure)
  finally show ?thesis .
qed

lemma program_result_measure':
 "qbs_prob_measure (qbs_prob_space (exp_qbs ℝQ ℝQ, (λ(s, b) r. s * r + b) ∘ real_real.g, density (distr (ν ⨂M ν) real_borel real_real.f) (λr. (obs ∘ (λ(s, b) r. s * r + b) ∘ real_real.g) r / C)))
   = distr (density (ν ⨂M ν) (λ(s,b). obs (λr. s * r + b) / C)) (qbs_to_measure (exp_qbs ℝQ ℝQ)) (λ(s, b) r. s * r + b)"
  by(simp only: program_result_measure distr_distr) (simp add: density_distr split_beta' prior_measure)

end